home *** CD-ROM | disk | FTP | other *** search
/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / Yerk 3.64 / nuc / yerk3.64.txt < prev   
Text File  |  1993-06-20  |  80KB  |  3,624 lines
  1. ; System 7 modifications
  2. ; courier 9pt -9 spacing tabs: .875 1.5 3.625
  3. ; need to change modification in vers RSRC
  4. ; flush caches in trap; fix d0 saves for flushes
  5. ; fixed s,; added ucase in word_
  6. ;    Load equates for Toolbox, Quickdraw
  7.     LIST OFF
  8.     INCLUDE    "library.asm"
  9.     INCLUDE    "equates.asm"
  10.     INCLUDE    "yerk.macro"
  11. *
  12. gestalt    EQU    $a1ad
  13. newhandc    EQU    $a322
  14. newPtrc    EQU    $a31e
  15. stripAddress    EQU    $a055
  16. waitNextEvt    EQU    $a860
  17. HWPriv    EQU    $a198
  18.     GLOBAL    $200,$200
  19.     ENDG
  20.     TFILE "YERK.BIN"
  21.     RFILE "YERK",APPL,YERK,$2100    ; has bundle,init
  22. ;
  23. Rsize    EQU    400    ; Maximum depth of ret+mstack
  24. Rbytes    EQU    -Rsize*4    ; Number of bytes for ret+mstack
  25. MSbytes    EQU    1200    ; 300 cells on methods stack
  26. sysVects    EQU    17    ; how many system vectors + 1 (for len)
  27. sysVecSz    EQU    sysVects*4    ; total len of system vector table
  28. ; 'SAVE' HEADER EQUATES.
  29. udp    EQU    0    ; User dictionary pointer
  30. ufence    EQU    4    ; User fence pointer
  31. uvocl    EQU    8    ; User vocabulary pointer
  32. ulatest    EQU    12    ; Latest NFA.
  33. headlen    EQU    16    ; Length of header
  34. ; Finder Handle Offsets
  35. opflag    EQU    0    ; Open/Print flag
  36. numfiles    EQU    2    ; Number of files
  37. volrnum    EQU    0    ; Volume reference number
  38. ftype    EQU    2    ; File type
  39. fvernum    EQU    6    ; File's version number
  40. fname    EQU    8    ; File name ( <count> <name> )
  41. f.handle    EQU    16    ; Offset to finder handle
  42. *
  43.     SEG    1,48
  44.     bra.s    start
  45. installed    data    /0    ; 0 if cold; 1 if warm; 2 if application
  46. getInstL    lea    installed(PC),a2    ; get Installed address in a2
  47.     rts
  48. start
  49.     lea    installed(PC),a2    ; see if this is a reboot
  50.     btst    #0,(a2)    ; if true, mem already acquired,
  51.     bne.s    already    ; skip initialization code
  52.     sjsr    getDict    ; load seg & get user dict size in d1
  53.     clr.l    -(sp)
  54.     move.l    #$434F4445,-(sp)    ; CODE
  55.     move.w    #2,-(sp)
  56.     _getResource
  57.     move.l    (sp),a0    ; keep handle on stack
  58.     clr.l    -(sp)    ; set up to get size of seg 2
  59.     move.l    a0,-(sp)
  60.     _SizeRsrc
  61.     move.l    (sp)+,d2    ; got size in d2
  62.     move.l    (sp),a0    ; recover handle
  63.     _Hunlock
  64.  
  65.     btst    #1,(a2)    ; if true, this is application
  66.     bne.s    isApp    ; don't change code size
  67.  
  68.     add.l    d2,d1    ; add nucleus length
  69. isApp    move.l    d1,d0
  70.     _SetHandleSize
  71.     tst.l    d0    ; did we get it?
  72.     beq.s    gotit
  73.     move.w    #3,-(sp)
  74.     _sysbeep
  75.     _exitToShell
  76. gotit
  77.     move.l    (sp)+,a0
  78.     _Hlock
  79.     lea    installed(PC),a0
  80.     ori.b    #1,(a0)    ; set true for installed
  81.     sjmp    origin
  82. already
  83.     sjmp    coldvec
  84.     ENDR
  85. *
  86.     SEG    2,48
  87. ;        begin USER initialization data
  88. origin    bra    ftInit    ; branch around initialization da
  89. one    EQU    origin
  90. segStart    EQU    origin-4
  91. lkorigin    EQU    origin    ; null link for first entry
  92. yerkID    ASC    "3640"    ; Release, version, revision, 0
  93.     ADJST
  94. initLast    DATA    Lastdef-origin    ; origin + 8: last definition addr
  95. initFenc    DATA    Lastdef-origin    ; fence
  96. initS0    DATA    0    ; offset from A3 for initial A7 (SP)
  97. initR0    DATA    0    ; offset from A3 for initial A6
  98. initmp    DATA    0    ; offset from A3 for initial D5
  99. initDP    DATA    0    ; DP - starts past sys vector table
  100. initVocl    DATA    0    ; VOC-LINK - last COLD init
  101. Userror    DATA    0    ; Error during load
  102. memsize    DATA    300000    ; user dictionary size for CODE2
  103. memPtr    DATA    0    ; abs ptr to the user dict heap
  104. userdp    DATA    0    ; Pointer to the user dict heap
  105. stksize    DATA    $ffffdcd8    ; 9000 stack size
  106. ;
  107. ;    End USER initialization data
  108. ;
  109. ftInit
  110.     link    a6,#rbytes    ; a6=R0,a7=S0 return stack
  111.     pea    -4(a5)
  112.     _InitGraf    ; initGraf(@thePort)
  113.     lea    origin(PC),a3    ; a3 -> code base at load
  114.     lea    stksize(PC),a0
  115.     move.l    (a0),d1
  116.     lea    0(a7,d1.l),a0    ; leave stack space
  117.     _setApplLimit
  118.     _MaxApplZone
  119.     _maxMem        ; force purge of the heap
  120. *
  121.     sjsr    getInstL    ; see if this is a reboot-from seg0
  122.     btst    #1,(a2)    ; if true, this is a program, so skip next
  123.     bne.s    noload
  124.     jsr    loaduser(PC)    ; load application dictionary if any
  125. noload    moveq    #(initS0-origin),d7    ; put offset into D7
  126.     move.l    SP,d0    ; store SP in d0
  127.     sub.l    a3,d0    ; reference to yerk base
  128.     move.l    d0,0(a3,d7.l)    ; inits0 now has offset to data stk
  129.     move.l    a6,d0    ; A6 points to methods stack
  130.     sub.l    a3,d0    ; reference to yerk base
  131.     lea    initmp(PC),a2    ; Init methods stack for cold load
  132.     move.l    d0,(a2)    ; initmp now has mstack offset
  133.     subi.l    #msbytes,d0    ; Leave 300 cells for M stack
  134.     move.l    d0,4(a3,d7.l)    ; initr0 now has offset to ret stk
  135. *
  136. COLDVEC    bra.s    ECLD    ; jump to cold start
  137. WARMVEC    bra.s    EWRM    ; jump to warm start
  138. ; =======Inner Interpreter ===========
  139. donext    move.l    (a4)+,d6    ; get next threaded instruction (32bit)
  140.     move.l    0(a3,d6.l),d7    ; get code address
  141.     jmp    0(a3,d7.l)    ; jump to code addr relative to a3
  142.     nop
  143. ECLD    movea.l    #applScratch,a2    ; fill scratch with warm start
  144.     move.w    #$4ef9,(a2)+    ; jmp
  145.     lea    ewrm(PC),a0
  146.     move.l    a0,(a2)    
  147. *
  148.     lea    cld1(PC),a4    ; A4 is IP in inner interpreter
  149.     bra.s    EWRM1
  150. EWRM    lea    warm1(PC),a4    ; A4 is IP in inner interpreter
  151. EWRM1    lea    origin(PC),a3
  152.     moveq    #(initS0-origin),d7    ; get address of initS0 in D7
  153.     movea.l    0(a3,d7.l),SP    ; pickup s0 address in SP
  154.     adda.l    a3,SP
  155.     movea.l    4(a3,d7.l),a6    ; pickup r0 address in a6
  156.     adda.l    a3,a6
  157.     move.l    initmp(PC),d5    ; Pick methods stack pointer
  158.     add.l    a3,d5
  159.     gonext
  160. ;
  161. ; GETDICT call from seg 0
  162. getDict    lea    memsize(PC),a1
  163.     move.l    (a1),d1
  164.     rts
  165. ;
  166. warm1    cfas    cls,abort,semis
  167. ; Loaduser routine loads the user dictionary if there is one to be loaded.
  168. ; First get some Heap to read the user dictionary into. We want
  169. ; get as much heap as there is available, minus some for the system.
  170. loaduser
  171.     lea    memsize(PC),a1    ; get initial space
  172.     move.l    (a1),d0
  173.     lea    nextdef+2(PC),a0    ; get top of nuc abs
  174.     sub.l    a0,d0    ; get user dict memsize acquired
  175.     add.l    a3,d0
  176. ;    move.l    d0,(a1)
  177.     asr.l    #2,d0           ; number of long words to clear
  178. clm    clr.l    (a0)+
  179.     dbra    d0,clm
  180.     lea    nextdef+2(PC),a0
  181.     lea    memptr(PC),a2
  182.     move.l    a0,(a2)    ; Save the memory pointer
  183. ; set up DP
  184.     suba.l    a3,a0    ; a0 has relative base of user dict
  185.     lea    initdp(PC),a2
  186.     move.l    a0,(a2)    ; Set default dp
  187.     andi.l    #$FFFFFF,(a2)    ; mask out hi byte  ????WHY
  188.     add.l    #sysvecSz,(a2)    ; bump dp past system vector table
  189. *
  190.     lea    userdp(PC),a2    ; Save pointer to dict. begin
  191.     move.l    a0,(a2)
  192.     andi.l    #$FFFFFF,(a2)
  193.     jsr    loadcom(PC)
  194.     rts
  195. ;
  196. ; Get the finder handle and see if there is file to be opened
  197. ;
  198. loadcom    movea.l    f.handle(a5),a0    ; Get finder handle
  199.     movea.l    (a0),a0    ; Dereference it
  200.     tst.w    (a0)    ; Check if open or print
  201.     beq    load010    ; ok to open
  202.     movea.l    #2,a0    ; error. we don't print
  203.     bra    loaderror
  204. ; The file is to be opened. See if there are any files to open.
  205. load010
  206.     tst.w    numfiles(a0)    ; any files to open?
  207.     bne    load020    ; at least one
  208.     movea.l    #1,a0    ; none. just the nucleus
  209.     bra    loaderror
  210. ; We have at least one file to be opened. Even if there are more than
  211. ; one at this point we are only going to open the first file picked.
  212. load020
  213.     adda.l    #4,a0    ; a0 points past the header
  214.     move.l    ftype(a0),a1    ; get filetype of the file
  215.     cmpa.l    #$434f4d20,a1    ; is it 'COM ' ?
  216.     bne    loaderror
  217.     lea    usefcb(PC),a1    ; load pointer to usefcb
  218.     lea    fname(a0),a2    ; load pointer to filename
  219.     move.l    a2,IoFileName(a1)    ; set file pointer in the fcb
  220.     lea    (a0),a2    ; load pointer to VRefNum
  221.     move.w    (a2),IoVRefNum(a1)    ; set VRefNum in the fcb
  222.     move.b    #1,IoPermssn(a1)    ; set i/o permission to readonly
  223.     move.l    a1,a0    ; Fcb in a0 for call
  224.     _open        ; Open the file
  225.     tst.w    IoResult(a0)    ; Check for errors
  226.     beq    load030    ; continue if ok
  227.     movea.l    IoResult(a0),a0    ; error code
  228.     bra    loaderror    ; Off to process errors
  229. ; Now get the file size so that we know how much to read in.
  230. load030    
  231.     movea.l    a1,a0    ; get the fcb back in a0
  232.     _getfileinfo    ; get info on the file
  233.     tst.w    IoResult(a0)    ; Check for errors
  234.     beq    load040    ; continue if ok
  235.     movea.l    IoResult(a0),a0    ; error code
  236.     bra    loaderror    ; Off to process errors
  237. load040
  238.     lea    nextdef+2(PC),a4    ; Get buffer addr
  239.     move.l    IoflLgLen(a0),d1    ; Get the logical length of file
  240.     movea.l    a1,a0    ; Fcb again
  241.     move.l    a4,iobuffer(a0)    ; Set buffer pointer for data in
  242.     move.l    #headlen,IoReqCount(a0)    ; Number of bytes to read
  243.     clr.l    IoPosMode(a0)    ; Read from beginning of file
  244.     clr.l    IoPosOffset(a0)    ; offset by 0
  245.     _read
  246.     tst.w    IoResult(a0)    ; Check for errors
  247.     beq    load060    ; continue if ok
  248.     movea.l    IoResult(a0),a0    ; error code
  249.     bra.s    loaderror    ; Off to process errors
  250. ; Initialize COLD load variables so that the user dictionary is included
  251. ; when the FORTH system is brought up.
  252. load060
  253.     lea    initdp(PC),a2
  254.     move.l    (a4),(a2)    ; Set dictionary pointer
  255.     lea    initfenc(PC),a2
  256.     move.l    ufence(a4),(a2)    ; Set fence pointer
  257.     lea    initvocl(PC),a2
  258.     move.l    uvocl(a4),(a2)    ; Set vocabulary link
  259.     lea    initLast(PC),a2
  260.     move.l    ulatest(a4),(a2)    ; Set latest NFA
  261. ; Now we can read the dictionary into the memory.
  262.     subi.l    #headlen,d1    ; Size of dictionary to read
  263.     move.l    d1,IoReqCount(a0)
  264.     clr.l    IoPosMode(a0)    ; Position to beginning of file
  265.     move.l    #headlen,IoPosOffset(a0)    ; Offset by headlen
  266.     _read        ; read the dictionary
  267.     tst.w    IoResult(a0)    ; Check for errors
  268.     beq    load070    ; continue if ok
  269.     movea.l    IoResult(a0),a0    ; error code
  270. loaderror
  271.     lea    userror(PC),a2
  272.     move.l    a0,(a2)    ; Save error code for cold
  273.     bra.s    load080
  274. load070
  275.     movea.l    a1,a0    ; fcb again
  276.     _close        ; Close the file
  277. load080
  278.     rts
  279. ; --------------------------------------
  280. ; area for calls to Toolbox, etc.
  281. ftwork    DEFS    20
  282. ftwork1    DC.L    0
  283. dsmsg    STR    "Parameter Stack:"
  284. rsmsg    STR    "Return Stack:   "
  285. msmsg    STR    "Methods Stack:  "
  286. emptymsg    STR    "  <empty>"
  287. pausemsg    STR    "Paused - <Space Bar> to continue>>>"
  288. bytesleft    STR    "Bytes Available: "
  289. hello    STR    "Macintosh Yerk Version 3.6.4"
  290.     ADJST
  291. tibbuf    DEFS    128    ; terminal input buffer
  292.     DATA    /0
  293.     DEFS    20    ; for numeric output
  294. padbuf    DEFS    256    ; text output buffer
  295. aregn    DATA    0    ; region handle for miscellany
  296.     ADJST
  297. ; Begin nucleus definitions
  298.     ADJST
  299. cld1    cfas    xcold,quit    ; do COLD word and enter Forth
  300. ; ====================================================
  301. ; Following are data areas that will be patched to look like objects
  302. ; after the Class/Object support code is in. Cfas will be patched to
  303. ; Class pointers.
  304. ; ====================================================
  305.     dcode    FWIND,x,origin,fwind ; link should be 0
  306. wRecord    
  307.     DEFS    windowsize    ; window record
  308.     DC.W    0,0,290,494    ; content rect boundaries
  309.     DC.W    8,8,340,510    ; grow rect boundaries
  310.     DC.W    -10000,-10000,10000,10000    ; drag rect boundaries
  311.     DC.W    1,1,1    ; growflg,dragflg, alive
  312.     DATA    nulw-origin    ; idle vector
  313.     DATA    cls-origin    ; deact vector
  314.     DATA    nulw-origin    ; content vector
  315.     DATA    nulw-origin    ; draw vector
  316.     DATA    nulw-origin    ; enact vector
  317.     DATA    nulw-origin    ; close vector
  318.     DC.W    $100    ; resid
  319.     DC.W    1    ; is this window scrollable?
  320.     DATA    0    ; special zoom cfa
  321.     dcode    FEVENT,x,fwind,fevent
  322. eventRec    DC.W    0    ; event record for GetNextEvent
  323. eventMsg    DC.L    0,0,0
  324. eventMod    DC.W    0
  325. eventmsk    DC.W    0
  326. eventSlp    DC.L    0
  327. mousRgn    DC.L    0
  328.     DC.W    4,23 ; header for event indexed area
  329.     DEFS    4*23
  330.     dcode    FFCB,x,fevent,ffcb
  331. ; ------------- Default FCB ------------
  332. useFCB    DEFS    144    ; Parm block for USING file
  333. useFname    DEFS    64    ; holds USING volume/file name string
  334. ; -----------------------------------------
  335. fcbl    EQU    *-useFCB    ; length of FCB
  336.     dcode    FPRECT,x,ffcb,fprect
  337. pRect    DC.W    0,0,294,470    ; Forth window rectangle
  338. ; =============================================================
  339.     dcode    ADOC,x,fprect,adoc
  340.     jsr    loadcom(PC)    ; load user dict according to fInfo
  341.     gonext
  342. ; system values
  343.     dval    S0,adoc,s0,0
  344.     dval    R0,S0,r0,0
  345.     dval    TIB,r0,tib,tibbuf-origin
  346.     dval    WARNING,tib,warn,1
  347.     dval    FENCE,warn,fence,0
  348.     dval    DP,fence,dp,0
  349.     dval    VOC-LINK,dp,vocl,0
  350.     dval    IN,vocl,in,0
  351.     dval    OUT,in,out,0
  352.     dval    CONTEXT,out,contxt,0
  353.     dval    CURRENT,contxt,currnt,0
  354.     dval    STATE,currnt,state,0
  355.     dval    CSTATE,state,cstate,0
  356.     dval    BASE,cstate,base,10
  357.     dval    DPL,base,dpl,0
  358.     dval    CSP,dpl,csp,0
  359.     dval    HLD,csp,hld,0
  360.     dval    WNEAVAIL,hld,wneavail,0    ; true if waitNextEvent in ROM
  361.     dval    HWPAVAIL,wneavail,hwpavail,0    ; true if flush cache
  362.     dval    HASGESTALT,hwpavail,hasGestalt,0    ; true if gestalt is in system
  363.     dval    HEAPTOP,hasGestalt,heapTop,0    ; top of heap filled at start
  364.     dval    HEAPBOT,heapTop,heapBot,0    ; bottom of heap filled at start
  365.     dval    UCASE,heapBot,ucase,1    ; flag for lowercase interpreting
  366.     dval    DOCS,ucase,docs,0    ; flag for document sources loaded
  367.     dval    LINE#,docs,line_,-1    ; line# in source file for documenation
  368.     dvect    VMODEL,line_,vmodel,nulw    ; model for other vectors
  369.     dcon    FILEMK,vmodel,filemk,-300+origin    ; file mark constant
  370.     dcon    NEXT,filemk,next,donext
  371.     dcon    BEGIN-DP,next,bdp,userdp    ; use @
  372.     dcon    LOAD-ERROR,bdp,lerror,Userror    ; use @
  373.     dval    M0,lerror,m0,0
  374.     dcon    USE-FCB,m0,ufcb,useFCB    ; pushes addr of useFCB
  375.     dcon    MSIZE,ufcb,msiz,memsize    ; use @
  376.     dcon    BL,msiz,bl,$20+origin
  377.     dcon    TRUE,bl,true,1+origin
  378.     dcon    FALSE,true,false,0+origin
  379.     dsvect    KEYVEC,false,keyvec,4,key_    ; system vectors for I/O
  380.     dsvect    EMITVEC,keyvec,emitvec,8,emit_    ; console emit
  381.     dsvect    PEMITVEC,emitvec,pemitv,12,drop    ; printer emit
  382.     dsvect    TYPEVEC,pemitv,typevec,16,type_    ; console type
  383.     dsvect    PTYPEVEC,typevec,ptypev,20,drop2
  384.     dsvect    EXPVEC,ptypev,expvec,24,expect    ; expect
  385.     dsvect    ECHOVEC,expvec,echovec,28,emit_    ; echo for keys
  386.     dsvect    ABORTVEC,echovec,abvec,32,nulw    ; installable abo
  387.     dsvect    QUITVEC,abvec,quvec,36,nulw    ; installable startup vector
  388.     dsvect    UFIND,quvec,ufind,40,false    ; vector for user find
  389.     dsvect    OBJINIT,ufind,objini,44,nulw    ; init nucleus objs
  390.     dsvect    PCRVEC,objini,pcrvec,48,nulw    ; printer CR
  391.     dsvect    BLDVEC,pcrvec,bldvec,52,nulw    ; object builder
  392.     dsvect    CREATE,bldvec,kreate,56,creat_    ; create vector
  393.     dsvect    INTERPRET,kreate,interp,60,intrp_
  394.     dsvect    CRVEC,interp,crvec,64,cr_
  395.     dval    DISK-ERROR,crvec,dkerr,0
  396.     dval    CURS,dkerr,curs_,1    ; cursor on/off flag
  397. crsflag    EQU    *-4
  398.     dval    UCFLAG,curs_,ucflag,1    ; map to upper case
  399. ; ==============================================
  400.     dcode    BYE,x,ucflag,bye_
  401.     _exitToShell
  402. *
  403.     dcode    (CODEZONE),x,bye_,instal
  404.     lea    segStart(PC),a1    ; set CODE 2 resource size
  405.     movea.l    a1,a0
  406.     _recoverHandle    ; get a handle to appl *** need to unlock
  407.     move.l    (a7)+,d0    ; get ending rel addr
  408.     addq.l    #1,d0
  409.     andi.l    #-2,d0    ; ensure even
  410.     addi.l    #4,d0    ; add CODE pointer length
  411.     _SetHandleSize    ; increase the size
  412.     gonext
  413. *
  414.     dcode    FINFO,x,instal,finfo    ; point to finder handle
  415.     movea.l    f.handle(a5),a0
  416.     movea.l    (a0),a0    ; dereference
  417.     suba.l    a3,a0    ; make relative
  418.     move.l    a0,-(SP)    ; push dereferenced ptr
  419.     gonext
  420. *
  421.     dcode    .CUR,x,finfo,dotcur    ; draw a cursor
  422.     jsr    pcurs(PC)
  423.     gonext
  424. *
  425. pcurs    lea    crsflag(PC),a0    ; ( -- )
  426.     tst.l    (a0)    ; is cursor on or off?
  427.     beq    nocurs
  428.     pea    ftwork(PC)
  429.     _GetPenState    ; get the current pen state
  430.     move.w    #10,-(SP)    ; set xor mode
  431.     _PenMode
  432.     move.w    #7,-(SP)
  433.     clr.w    -(SP)
  434.     _Line
  435.     pea    ftwork(PC)
  436.     _SetPenState
  437. nocurs    rts
  438. *
  439.     dcode    (EMIT),x,dotcur,emit_
  440.     jsr    pcurs(PC)
  441.     addq.l    #2,SP    ; long -> integer
  442.     _DrawChar    ; expects Pascal CHAR on stack
  443.     jsr    pcurs(PC)
  444.     gonext
  445. *
  446.     dcode    (TYPE),x,emit_,type_
  447.     move.l    a3,d0
  448.     add.l    d0,4(SP)    ; make address absolute
  449.     clr.l    d0
  450.     move.w    2(SP),d0
  451.     swap    d0
  452.     move.l    d0,(SP)    ; zero start byte offset
  453.     _DrawText
  454.     jsr    pcurs(PC)
  455.     gonext
  456. *
  457.     dcode    NULW,x,type_,nulw    ; empty word for stubbing vectors
  458.     gonext
  459. *
  460.     dcode    WORD0,x,nulw,word0    ; push a word of 0 for function setup
  461.     clr.w    -(SP)
  462.     gonext
  463. *
  464.     dcode    PACK,x,word0,pack_    ; packs 2 longs into one
  465.     popd0        ; get y
  466.     addq.l    #2,SP
  467.     move.w    d0,-(SP)
  468.     gonext
  469. *
  470.     dcode    UNPACK,x,pack_,unpack
  471.     move.l    (sp),d0
  472.     move.w    d0,d1
  473.     ext.l    d1
  474.     move.l    d1,(SP)
  475.     asr.l    #8,d0
  476.     asr.l    #8,d0
  477.     move.l    d0,-(SP)
  478.     gonext
  479. *
  480.     dcode    I->L,x,unpack,itol    ; extend 16 bit stack cell to 32
  481.     move.w    (sp)+,d0
  482.     ext.l    d0
  483.     move.l    d0,-(SP)
  484.     gonext
  485. *
  486.     dcode    MAKEINT,x,itol,makint
  487.     addq.l    #2,SP    ; drop high-level word on stack
  488.     gonext
  489. *
  490.     dcode    NEWPTR,x,makint,xnewpt
  491.     popd0        ; get size for new block in d0
  492.     _NewPtrC    ; call the memory manager for a new block
  493.     sub.l    a3,a0    ; make ptr relative
  494.     move.l    a0,-(SP)    ; push ptr to nonrelocatable block
  495.     gonext
  496. *
  497.     dcode    NEWHANDLE,x,xnewpt,xnewha
  498.     popd0
  499.     _newHandC    ; special vers of _NewHandle
  500.     move.l    a0,-(SP)    ; push handle to relocatable block
  501.     gonext
  502. *
  503. *    ( hndl -- b)
  504.     dcode    ?ISHANDLE,x,xnewha,ishand
  505.     movea.l    (sp),a0    ; get hndl
  506.     move.l    a0,d0    ; make copy for compares
  507.     btst    #0,d0    ; not hndl if odd
  508.     bne.s    no
  509.  
  510.     sub.l    a3,d0    ; into yerk mem space
  511.     cmp.l    heapBot9-origin(a3),d0    ; is hndl in prgm heap
  512.     blt.s    no    ; not hndl if < bot
  513.  
  514.     cmp.l    heapTop9-origin(a3),d0
  515.     bgt.s    no    ; not hndl if > top
  516.  
  517.     move.l    (a0),d0    ; get pointer
  518.     btst    #0,d0    ; not hndl if ptr odd
  519.     bne.s    no
  520.  
  521.     move.l    d0,d1    ; save ptr copy
  522.     sub.l    a3,d1    ; into yerk mem space
  523.     cmp.l    heapBot9-origin(a3),d1    ; is ptr in prgm heap
  524.     blt.s    no    ; not if < bot
  525.  
  526.     cmp.l    heapTop9-origin(a3),d1
  527.     bgt.s    no    ; not if > top
  528.  
  529.     movea.l    a0,a1    ; copy hndl
  530.     movea.l    d0,a0    ; move ptr into a0
  531.     _recoverHandle
  532.     cmp.l    a0,a1    ; are hndls equal
  533.     bne.s    no
  534.  
  535.     moveq    #1,d0    ; set true flag
  536.     bra.s    yes
  537.  
  538. no    moveq    #0,d0    ; set false flag
  539. yes    move.l    d0,(sp)
  540.     gonext
  541. *
  542.     dcode    LOCK,x,ishand,xlock
  543.     movea.l    (SP),a0    ; get handle in a0
  544.     _hLock        ; mark the block locked
  545.     movea.l    (SP),a0
  546.     movea.l    (a0),a1    ; dereference the handle
  547.     suba.l    a3,a1    ; make it a Forth address based on a3
  548.     move.l    a1,(SP)    ; leave Forth address on stack
  549.     gonext
  550. *
  551.     dcode    KILLPTR,x,xlock,killpt    ; (relPtr -- )
  552.     movea.l    (SP)+,a0    ; get rel ptr in a0
  553.     add.l    a3,a0    ; make it absolute
  554.     _disposPtr    ; release it
  555.     gonext
  556. *
  557.     dcode    KILLHANDLE,x,killpt,killha
  558.     movea.l    (SP)+,a0    ; get handle
  559.     _disposHandle
  560.     gonext
  561. *    
  562.     dcode    GROWPTR,x,killha,groptr    ; ( bytes relptr --)
  563.     movea.l    (SP)+,a0    ; get rel ptr in a0
  564.     adda.l    a3,a0    ; make it absolute
  565.     move.l    a0,d4
  566.     _getPtrSize
  567.     add.l    (sp)+,d0    ; get new handle size
  568.     movea.l    d4,a0
  569.     _SetPtrSize    ; grow the block
  570.     gonext
  571. *
  572.     dcode    FREE,x,groPtr,free_    ; ( -- maxAvail )
  573.     _freeMem        ; what is max mem avail on heap?
  574.     pushd0        ; includes purging
  575.     gonext
  576. *
  577.     dcode    FREEBLK,x,free_,freblk
  578.     _maxmem        ; what is max mem avail on heap?
  579.     pushd0        ; includes purging
  580.     gonext
  581. *
  582.     dcode    >PTR,x,freblk,fetptr    ; ( handle    --- relptr )
  583.     movea.l    (SP),a0
  584.     move.l    (a0),d0    ; dereference a handle
  585.     tst.b    wneavail9+3-origin(a3)    ; if wne, then stripaddr
  586.     beq.s    noStrip
  587.     _stripAddress
  588.     bra.s    onPtr
  589. noStrip    and.l  lo3bytes,d0
  590. onPtr    sub.l   a3,d0
  591.     move.l    d0,(SP)    ; return its pointer
  592.     gonext
  593. *
  594.     dcode    GET-EVENT,x,fetptr,getevt
  595.     move.l    (SP)+,d7    ; get event mask into d7
  596.     swap    d7
  597. ev1    move.l    d7,-(SP)    ; make room for function return
  598.     lea    eventRec(PC),a0 ; ptr to event rec storage
  599.     move.l    a0,-(sp)
  600.     tst.b    wneavail9+3-origin(a3)    ; is waitnextevent here?
  601.     beq.s    usegne0
  602.     move.l    18(a0),-(sp)    ; get sleep value
  603.     move.l    22(a0),-(sp)    ; get mouse rgn
  604.     _waitNextEvt
  605.     bra.s    endevt0
  606. usegne0    _SystemTask    ; WNE not in ROM
  607.     _GetNextEvent
  608. endevt0    tst.w    (SP)+    ; should we handle this event?
  609.     beq    ev1    ; no - get another one
  610.     lea    eventRec(PC),a0
  611.     clr.l    d0
  612.     move.w    (a0),d0    ; pick up event type
  613.     beq.s    ev1    ; loop if null event
  614.     pushd0        ; push event type for caller
  615.     gonext
  616. *
  617.     dcode    ?EVENT,x,getevt,qevt
  618.     move.l    (SP)+,d7    ; get event mask into d0
  619.     swap    d7
  620.     move.l    d7,-(SP)    ; make room for function return
  621.     pea    eventRec(PC)    ; pointer to event rec storage
  622.     _EventAvail    ; call Toolbox
  623.     tst.w    (SP)+    ; should we handle this event?
  624.     beq    event1    ; no - return false
  625.     lea    eventRec(PC),a0
  626.     clr.l    d0
  627.     move.w    (a0),d0    ; pick up event type
  628.     beq    event1    ; loop if null event
  629. event2    move.l    #1,-(SP)    ; push true - event available
  630.     bra.s    event3
  631. event1    clr.l    -(SP)    ; push false - no event available
  632. event3    gonext
  633. *
  634.     dcode    GETEVENT,x,qevt,gevt    ; (  --- b )
  635.     clr.w    -(sp)    ; make room for function return
  636.     lea    eventRec(PC),a0
  637.     move.w    eventMsk-eventRec(a0),-(sp)    ; get event mask
  638.     move.l    a0,-(sp)
  639.     tst.b    wneavail9+3-origin(a3)    ; is waitnextevent here?
  640.     beq.s    usegne
  641.     move.l    18(a0),-(sp)    ; get sleep value
  642.     move.l    22(a0),-(sp)    ; get mouse rgn
  643.     _waitNextEvt
  644.     bra.s    endevt
  645. usegne    _SystemTask    ; WNE not in ROM
  646.     _GetNextEvent
  647. endevt    clr.w    -(SP)    ; make an integer a long
  648.     gonext
  649. *
  650.     dcode    @EVENT-MSG,x,gevt,ftemsg
  651.     lea    eventMsg(PC),a0
  652.     move.l    (a0),-(SP)    ; push contents of last event msg
  653.     gonext
  654. *
  655. ; Flush the caches on 030,040 machines
  656.     dcode    CFLUSH,x,ftemsg,cflush
  657.     tst.b    hwpavail9+3-origin(a3)
  658.     beq.s    noflush
  659.     moveq    #1,d0
  660.     _HWPriv
  661. noflush    gonext
  662. *
  663. ; FIND-WINDOW ( point -- region, wptr )
  664.     dcode    FIND-WINDOW,x,cflush,findw
  665.     popd0
  666.     clr.w    -(SP)
  667.     pushd0
  668.     pea    ftwork1(PC)
  669.     _FindWindow
  670.     clr.w    -(SP)
  671.     lea    ftwork1(PC),a0
  672.     move.l    (a0),d0
  673.     sub.l    a3,d0
  674.     pushd0
  675.     gonext
  676. *
  677.     dcode    INIT-TOOLS,x,findw,intool
  678.     _InitFonts
  679.     move.l    #$ffff,d0    ; every event rfl 10/89
  680.     _FlushEvents
  681.     _InitWindows
  682.     _TEInit
  683.     pea    EWRM(PC)    ; warm start for Resume button
  684. ;in deep shit
  685.     _InitDialogs
  686.     clr.l    -(SP)    ; for windowPtr return
  687.     move.w    #256,-(SP)    ; window ID
  688.     pea    wrecord(PC)
  689.     move.l    #-1,-(SP)    ; POINTER(-1) for front window
  690.     _GetNewWindow    ; get window resource def
  691.     _setPort        ; setPort(WindowPtr)
  692.     lea    wrecord(PC),a0
  693.     move.w    #9,txSize(a0)    ; window text size = 9
  694.     move.w    #4,txfont(a0)    ; window text font
  695.     lea    pRect(PC),a1
  696.     move.l    portRect(a0),(a1)
  697.     move.l    portRect+4(a0),4(a1)
  698.     clr.l    -(SP)
  699.     _NewRgn
  700.     lea    aRegn(PC),a0
  701.     move.l    (SP)+,(a0)    ; fill in region handle
  702.     clr.w    -(SP)
  703.     _TextMode    ; source copy text mode
  704.     _Initmenus
  705.     _InitCursor
  706.     move.w    #$9f,d0    ; check for trap availability
  707.     _getTrapAddress+$600
  708.     move.l    a0,d3    ; d3 = unimplemented trap addr
  709.     moveq  #$60,d0    ; check for WaitNextEvent
  710.     _getTrapAddress+$600
  711.     cmp.l    a0,d3    ; if <> waitnextevent is avail
  712.     sne    d0
  713.     move.b    d0,wneavail9+3-origin(a3)
  714.     move.l    #$198,d0    ; hwpriv trap addr
  715.     _getTrapAddress+$200
  716.     cmp.l    a0,d3    ; if <> hwpriv is avail
  717.     sne    d0
  718.     move.b    d0,hwpavail9+3-origin(a3)
  719.     move.l  #$1ad,d0    ; gestalt avail
  720.     _getTrapAddress+$200
  721.     cmp.l    a0,d3
  722.     sne    d0
  723.     move.b    d0,hasGestalt9+3-origin(a3)
  724.     move.l    heapend,d0
  725.     sub.l    a3,d0
  726.     move.l    d0,heapTop9-origin(a3)
  727.     move.l    applzone,d0
  728.     sub.l    a3,d0
  729.     move.l    d0,heapBot9-origin(a3)    
  730.     gonext
  731. *
  732.     dcode    HOME,x,intool,home
  733. dohome    move.l    #$f0008,d0
  734.     pushd0
  735.     _MoveTo        ; home
  736.     gonext
  737. *
  738.     dcode    CLS,x,home,cls
  739.     pea    pRect(PC)
  740.     _EraseRect
  741.     jmp    dohome(PC)
  742.     gonext
  743. *
  744.     dcode    SCROLL,x,cls,scroll    ; (dh dv --- )
  745.     popd0
  746.     popd1
  747.     pea    pRect(PC)
  748.     move.w    d1,-(SP)
  749.     move.w    d0,-(SP)
  750.     lea    aregn(PC),a0    ; get dummy region handle
  751.     move.l    (a0),-(SP)
  752.     _ScrollRect
  753.     gonext
  754. *
  755.     dcode    >ORIGIN,x,scroll,setorg
  756.     popd0
  757.     addq.l    #2,SP
  758.     move.w    d0,-(SP)
  759.     _SetOrigin
  760.     gonext
  761. *
  762.     dcode    LINE,x,setorg,xline    ; (dh dv ---)
  763.     popd0
  764.     addq.l    #2,SP
  765.     move.w    d0,-(SP)
  766.     _Line
  767.     gonext
  768. *
  769.     dcode    LINETO,x,xline,xline2    ; (x y --)
  770.     popd0
  771.     addq.l    #2,SP
  772.     move.w    d0,-(sp)
  773.     _LineTo
  774.     gonext
  775. *
  776.     dcode    LIT,x,xline2,lit ; build code header
  777.     move.l    (a4)+,-(SP)    ; push value at IP to stack
  778.     gonext
  779. *
  780.     dcode    WLIT,x,lit,wlit    ; build code header
  781.     move.w    (a4)+,-(SP)    ; push value at IP to stack
  782.     clr.w    -(SP)    ; extend to 32 bits
  783.     gonext
  784. *
  785.     dcode    WLITW,x,wlit,wlitw    ; build code header
  786.     move.w    (a4)+,-(sp)    ; push value at IP to stack
  787.     gonext    ; no extend
  788. *    
  789.     dcode    W@(IP),x,wlitw,wfetip
  790.     move.l    (a6),d0    ; get IP from 1 nest back
  791.     move.w    0(a3,d0.l),-(SP)    ; push the word
  792.     clr.w    -(SP)
  793.     add.l    #2,(a6)    ; increment old IP past word
  794.     gonext
  795. *
  796.     dcode    EXECUTE,x,wfetip,exec
  797.     move.l    (SP)+,d6    ; pop address to execute
  798.     move.l    0(a3,d6.l),d7    ; get contents of CFA
  799.     jmp    0(a3,d7.l)    ; execute the code
  800. *
  801.     dcode    TRAP,x,exec,trap_    ; execute passed-in Tool trap
  802.     popD0        ; get trap in d0
  803.     lea    trapword(PC),a0
  804.     move.w    d0,(a0)    ; store trap inline for execution
  805.     tst.b    hwpavail9+3-origin(a3)
  806.     beq.s    trapword    ; don't flush if hwpriv unavail
  807.     moveq    #1,d0    ; flush the cache on 030,040
  808.     _HWPriv
  809.     nop        ; so we don't get burned by prefetch
  810. trapword    DC.W    $A997    ; start with openresfile
  811.     gonext
  812. *
  813.     dcode    (GESTALT),x,trap_,gestalt_
  814.     moveq    #-1,d0
  815.     move.b    hasGestalt9+3-origin(a3),d1
  816.     beq        nogest
  817.     move.l    (sp),d0
  818.     clr.l    d1
  819.     move.l    d1,a0
  820.     _gestalt
  821.     move.l    a0,(sp)
  822.     ext.l    d0
  823.     bmi.s    nogest
  824.     moveq    #0,d0
  825.     bra.s    isgest
  826. nogest    addq    #4,sp
  827. isgest    move.l    d0,-(sp)
  828.     gonext
  829. *
  830.     dcode    GOTOXY,x,gestalt_,gotoxy
  831.     popd0        ; get Y in d0
  832.     addq.l    #2,SP    ; drop high-level word on stack
  833.     move.w    d0,-(SP)
  834.     _MoveTo        ; call Quickdraw to move pen
  835.     gonext
  836. *
  837.     dcode    BEEP,x,gotoxy,beep    ; ( dur -- )
  838.     addq.l    #2,sp
  839.     _sysbeep
  840.     gonext
  841. *
  842.     dcode    @XY,x,beep,fetxy    ; return X,Y pen location
  843.     pea    ftwork(PC)
  844.     _GetPen
  845.     lea    ftwork(PC),a0
  846.     clr.l    d0
  847.     move.w    2(a0),d0
  848.     pushd0        ; push X value
  849.     move.w    (a0),d0
  850.     pushd0        ; push Y value
  851.     gonext
  852. *
  853.     dcode    BRANCH,x,fetxy,bran
  854.     adda.l    (a4),a4    ; add relative offset to IP
  855.     gonext
  856. *
  857.     dcode    0BRANCH,x,bran,bran0
  858.     move.l    (SP)+,d0    ; pop data stack into d0
  859.     bne    br1    ; if non-0, ignore branch following
  860.     adda.l    (a4),a4    ; else take the branch
  861.     bra.s    br2
  862. br1    addq.l    #4,a4    ; next 32-bit cfa
  863. br2    gonext
  864. *
  865.     dcode    OFBR,x,bran0,ofbr    ; 0branch used by OF clauses
  866.     move.l    (SP)+,d0    ; pop data stack into d0
  867.     bne    ofbr1    ; if non-0, ignore branch
  868.     move.l    (a6),d1    ; get IP from return stack
  869.     move.l    0(a3,d1.l),d2
  870.     add.l    d2,(a6)    ; add to stacked IP
  871.     bra.s    ofbr2
  872. ofbr1    addq.l    #4,(a6)    ; next 32-bit cfa 1 nest back
  873.     addq.l    #4,SP    ; drop the value
  874. ofbr2    gonext
  875. *
  876.     dcode    FAKE,x,ofbr,fake_    ; use as a breakpoint with debugg
  877.     jmp    *(PC)
  878.     gonext
  879. *
  880.     dcode    (LOOP),x,fake_,loop_    ; (loop)
  881.     addq.l    #1,(a6)    ; bump index (long)
  882.     move.l    (a6),d0
  883.     cmp.l    4(a6),d0    ; compare index to limit
  884.     bge    xloop1
  885.     adda.l    (a4),a4    ; branch back to top of loop
  886.     gonext
  887. xloop1    addq.l    #8,a6    ; pop index,limit from return stack
  888.     addq.l    #4,a4
  889.     gonext
  890. *
  891.     dcode    (DO),x,loop_,do_    ; this DO terminates on limit=count
  892.     move.l    (SP),d0
  893.     cmp.l    4(SP),d0    ; does limit=count? if so, terminate
  894.     bne    doloop
  895.     adda.l    (a4),a4    ; forward jump IP
  896.     addq.l    #8,SP
  897.     gonext
  898. doloop    move.l    4(SP),-(a6)    ; limit val to Return stack
  899.     move.l    d0,-(a6)    ; start val
  900.     addq.l    #4,a4    ; skip the jump addr
  901.     addq.l    #8,SP
  902.     gonext
  903. *
  904.     dcode    (LOOP+),x,do_,ploop_
  905.     move.l    (SP)+,d0
  906.     bmi    xploop1
  907.     add.l    d0,(a6)
  908.     move.l    (a6),d0
  909.     cmp.l    4(a6),d0
  910.     bge    xploop2
  911.     adda.l    (a4),a4
  912.     bra.s    xploop3
  913. xploop1    add.l    D0,(a6)
  914.     move.l    (a6),d0
  915.     cmp.l    4(a6),d0
  916.     ble    xploop2
  917.     adda.l    (a4),a4
  918.     bra.s    xploop3
  919. xploop2    addq.l    #8,a6
  920.     addq.l    #4,a4
  921. xploop3    gonext
  922. *
  923.     dcode    I,x,ploop_,i
  924.     move.l    (a6),-(SP)
  925.     gonext
  926. *
  927.     dcode    I+,x,i,iplus    ; add I to top of stack
  928.     move.l    (a6),d0
  929.     add.l    d0,(SP)
  930.     gonext
  931. *
  932.     dcode    I-,x,iplus,iminus
  933.     move.l    (a6),d0
  934.     sub.l    d0,(SP)
  935.     gonext
  936. *
  937.     dcode    I@,x,iminus,ifetch    ; fetch from I as addr
  938.     move.l    (A6),d7
  939.     move.l    0(a3,d7.l),-(sp)
  940.     gonext
  941. *
  942.     dcode    I!,x,ifetch,istore
  943.     move.l    (A6),d7
  944.     move.l    (SP)+,0(a3,d7.l)
  945.     gonext
  946. *
  947.     dcode    IC@,x,istore,icfet
  948.     clr.l    d0
  949.     move.l    (a6),d7
  950.     move.b    0(a3,d7.l),d0
  951.     move.l    d0,-(SP)
  952.     gonext
  953. *
  954.     dcode    IC!,x,icfet,icstor
  955.     move.l    (A6),d7
  956.     move.l    (sp)+,d0
  957.     move.b    d0,0(a3,d7.l)
  958.     gonext
  959. *
  960.     dcode    J,x,icstor,j
  961.     move.l    8(a6),-(SP)
  962.     gonext
  963. *
  964.     dcode    DIGIT,x,j,digit
  965.     popd0
  966.     popd1
  967.     clr.l    d2
  968.     subi.l    #$30,d1
  969.     bmi    dig2
  970.     cmpi.l    #$0a,d1
  971.     bmi    dig1
  972.     subq.l    #7,d1
  973.     cmpi.l    #$0a,d1    ; to fix FIG bug that lets 58-64 pass
  974.     bmi    dig2
  975. dig1    cmp.l    d0,d1
  976.     bge    dig2
  977.     moveq    #1,d2
  978.     pushd1
  979. dig2    pushd2
  980.     gonext
  981. *
  982.     dcode    TRAVERSE,x,digit,traver
  983.     popd0
  984.     popd1
  985.     moveq    #$20,d2
  986.     lea    0(a3,d1.l),a0
  987.     tst.l    d0
  988.     bmi    trav1
  989.     move.b    (a0),d0
  990.     andi.l    #$1f,d0
  991.     adda.l    d0,a0
  992.     move.l    a0,d0
  993.     andi.l    #1,d0
  994.     suba.l    d0,a0
  995.     addq.l    #1,a0
  996.     bra.s    trav2
  997. trav1    tst.b    (a0)
  998.     bmi    trav2
  999.     subq.l    #1,d2    ; exit early if drags on
  1000.     beq    trav2
  1001.     subq.l    #1,a0
  1002.     bra.s    trav1
  1003. trav2    suba.l    a3,a0
  1004.     move.l    a0,-(SP)
  1005.     gonext
  1006. *
  1007.     dcode    (FIND),x,traver,find_
  1008.     clr.l    d1
  1009.     move.l    (SP)+,d7
  1010.     lea    0(a3,d7.l),a0
  1011. pfind1    movea.l    a0,a2
  1012.     move.l    (SP),d7
  1013.     lea    0(a3,d7.l),a1
  1014.     move.b    (a2)+,d1
  1015.     andi.l    #$03f,d1
  1016.     cmp.b    (a1)+,d1
  1017.     bne    pfind3
  1018.     move.l    d1,d0
  1019. pfind2    cmpm.b    (a1)+,(a2)+
  1020.     bne    pfind3
  1021.     subq.l    #1,d0
  1022.     bne.s    pfind2
  1023.     bsr    odd
  1024.     addq.l    #8,a2
  1025.     suba.l    a3,a2
  1026.     move.l    a2,(SP)
  1027.     move.b    (a0),d0
  1028.     pushD0
  1029.     moveq    #1,d0
  1030.     bra.s    pfind4
  1031. pfind3    movea.l    a0,a2
  1032.     andi.w    #$1f,d1
  1033.     adda.l    d1,a2
  1034.     addq.l    #1,a2
  1035.     bsr    odd
  1036.     move.l    (a2),d7
  1037.     lea    0(a3,d7.l),a0
  1038.     tst.l    (a2)
  1039.     bne.s    pfind1
  1040.     addq.l    #4,SP
  1041.     clr.l    d0
  1042. pfind4    pushD0
  1043.     gonext
  1044. odd    move.l    a2,d0
  1045.     moveq    #1,d1
  1046.     and.l    d1,d0
  1047.     adda.l    d0,a2
  1048.     rts
  1049. *
  1050. ; ( SelPfa ^class -- f OR 1cfa t)
  1051.     dcode    ((FINDM)),x,find_,findm_
  1052.     move.l    (SP)+,d7    ; get relative ^class
  1053.     move.l    (SP)+,d0    ; get SelPfa to match
  1054.     move.l    0(a3,d7.l),d7    ; get contents of ^methods link field
  1055. findm0    lea    0(a3,d7.l),a1    ; get absolute ^methods dict nfa
  1056. findm1    cmp.w    (a1),d0    ; is this the method we want?
  1057.     beq    foundm    ; yes, we found the method
  1058.     move.l    2(a1),d7    ; link to previous method entry
  1059.     beq    notfndm    ; end of methods dict - not found
  1060.     bra.s    findm0
  1061. foundm    addi.l    #10,d7    ; point to 1cfa of method
  1062.     move.l    d7,-(SP)    ; push 1cfa to stack
  1063.     move.l    #1,-(SP)    ; true
  1064.     bra.s    fmexit    ; return to Forth
  1065. notFndm    clr.l    -(SP)
  1066. fmexit    gonext
  1067. *
  1068. *    ( addr delim -- addr n1 n2 n3 )
  1069.     dcode    ENCLOSE,x,findm_,enclos
  1070.     popd0        ; get delim in d0
  1071.     move.l    (SP),d7    ; addr in d7
  1072.     lea    0(a3,d7.l),a0    ; a0 has abs addr
  1073.     clr.l    d1
  1074. encGet    move.b    (a0)+,d2    ; get next byte in d2
  1075.     beq    encNull    ; null - unconditional exit
  1076.     cmpi.b    #9,d2    ; is char a Tab?
  1077.     bne    notab1
  1078.     move.b    #32,d2    ; map tabs to spaces
  1079. notab1    cmp.b    d0,d2    ; does first char = delim?
  1080.     bne    encNext    ; no
  1081.     addq.l    #1,d1    ; get another char
  1082.     bra.s    encGet
  1083. encNull    pushd1        ; found null- push idx at null
  1084.     addq.l    #1,d1    ; push idx of byte following
  1085.     pushd1
  1086.     bra.s    encl5    ; exit
  1087. encNext    pushd1        ; idx of first non-delim
  1088.     subq.l    #1,a0
  1089. encl3    move.b    (a0)+,d2
  1090.     beq    encl4
  1091.     cmp.b    #9,d2    ; is char a Tab?
  1092.     bne    notab2
  1093.     move.b    #32,d2    ; map tabs to spaces
  1094. notab2    cmp.b    d0,d2
  1095.     beq    encl4
  1096.     addq.l    #1,d1
  1097.     bra.s    encl3
  1098. encl4    move.l    d1,-(SP)
  1099.     tst.b    d2
  1100.     beq    encl5
  1101.     addq.l    #1,d1
  1102. encl5    pushd1        ; push unexamined idx and leave
  1103.     gonext
  1104. *
  1105.     dcode    (S=),x,enclos,sequ_    ; ( addr addr len -- b)
  1106.     popd0        ; get length of string comparison
  1107.     subq.l    #1,d0    ; setup counter for dbeq
  1108.     movea.l    (SP)+,a0
  1109.     movea.l    (SP)+,a1
  1110.     adda.l    a3,a0
  1111.     adda.l    a3,a1
  1112. dosequ    cmpm.b    (a0)+,(a1)+
  1113.     dbne    d0,dosequ
  1114.     cmp.w    #-1,d0
  1115.     beq    xsequ    ; counter was exhausted, so true
  1116.     clr.l    -(SP)    ; push false
  1117.     bra.s    nextsequ
  1118. xsequ    move.l    #1,-(SP)    ; push true
  1119. nextsequ    gonext
  1120. *
  1121.     dcode    CMOVE,x,sequ_,cmove
  1122. docmove    move.l    (SP)+,d0
  1123.     movea.l    (SP)+,a1
  1124.     movea.l    (SP)+,a0
  1125.     adda.l    a3,a0
  1126.     adda.l    a3,a1
  1127. cmov1    _BlockMove
  1128.     gonext
  1129. *
  1130. ; the somewhat dreaded multiply routines
  1131. mpy    move.l    (SP)+,-(a6)    ; save return address from jsr
  1132.     tst.w    (SP)    ; try short multiply first
  1133.     bne    mpy1
  1134.     tst.w    4(SP)    ; if both high words=0, we
  1135.     bne    mpy1    ; can do a short multiply
  1136.     popd0
  1137.     popd1
  1138.     mulu    d0,d1
  1139.     pushd1
  1140.     clr.l    d1
  1141.     pushd1
  1142.     move.l    (a6)+,-(SP)
  1143.     rts
  1144. mpy1    popd0        ; this is long multiply
  1145.     popd1
  1146.     moveq    #0,d2
  1147.     move.l    d2,-(SP)
  1148.     move.l    d2,-(SP)
  1149.     move.w    d1,d2
  1150.     mulu    d0,d2
  1151.     move.l    d2,4(SP)
  1152.     move.l    d1,d2
  1153.     swap    d2
  1154.     mulu    d0,d2
  1155.     add.l    d2,2(SP)
  1156.     swap    d0
  1157.     move.w    d1,d2
  1158.     mulu    d0,d2
  1159.     add.l    d2,2(SP)
  1160.     bcc    mpy2
  1161.     addq.w    #1,(SP)
  1162. mpy2    move.l    d1,d2
  1163.     swap    d2
  1164.     mulu    d0,d2
  1165.     add.l    d2,(SP)
  1166.     move.l    (a6)+,-(SP)
  1167.     rts
  1168. smpy    move.l    (SP)+,-(a6)
  1169.     tst.l    (SP)    ; signed multiply
  1170.     smi    d4
  1171.     bpl    smpy1
  1172.     neg.l    (SP)
  1173. smpy1    tst.l    4(SP)
  1174.     smi    d3
  1175.     bpl    smpy2
  1176.     neg.l    4(SP)
  1177. smpy2    eor.b    d3,d4
  1178.     bsr.s    mpy
  1179.     tst.b    d4
  1180.     beq    smpy3
  1181.     neg.l    4(SP)
  1182.     negx.l    (SP)
  1183. smpy3    move.l    (a6)+,-(SP)
  1184.     rts
  1185. xdiv    move.l    (SP)+,-(a6)
  1186.     tst.l    (SP)
  1187.     beq    div5
  1188.     tst.w    (SP)
  1189.     bne    longdiv
  1190.     tst.l    4(SP)
  1191.     bne    longdiv
  1192.     move.l    (SP)+,d2
  1193.     popd0
  1194.     popd1
  1195.     divu    d2,d1
  1196.     bvs    long1
  1197.     clr.l    d2
  1198.     move.w    d1,d2
  1199.     clr.w    d1
  1200.     swap    d1
  1201.     pushd1
  1202.     move.l    d2,-(SP)
  1203.     move.l    (a6)+,-(SP)
  1204.     rts
  1205. longdiv    move.l    (SP)+,d2    ; the dreaded long division
  1206.     popd0
  1207.     popd1
  1208. long1    moveq    #32,d3
  1209.     sub.l    d2,d0
  1210. div1    bmi    div2
  1211.     ori.l    #1,d1
  1212.     subq.w    #1,d3
  1213.     bmi    div3
  1214.     asl.l    #1,d1
  1215.     roxl.l    #1,d0
  1216.     sub.l    d2,d0
  1217.     bra.s    div1
  1218.     
  1219. div2    subq.w    #1,d3
  1220.     bmi    div3
  1221.     asl.l    #1,d1
  1222.     roxl.l    #1,d0
  1223.     add.l    d2,d0
  1224.     bra.s    div1
  1225. div3    tst.l    d0
  1226.     bpl    div4
  1227.     add.l    d2,d0
  1228. div4    pushd0
  1229.     pushd1
  1230.     move.l    (a6)+,-(SP)
  1231.     rts
  1232. div5    addq.l    #4,SP
  1233.     move.l    d2,4(SP)
  1234.     move.l    #$7fffffff,(SP)
  1235.     move.l    (a6)+,-(SP)
  1236.     rts
  1237. sdiv    move.l    (SP)+,-(a6)    ; save return address from jsr
  1238.     tst.l    (SP)    ; signed divide
  1239.     smi    d7    ; d4 change to d7  8-24-91
  1240.     bpl    sdiv1
  1241.     neg.l    (SP)
  1242. sdiv1    tst.l    4(SP)
  1243.     smi    d4    ; d7 changed to d4 to let rem sign = quotient sign
  1244.     bpl    sdiv2
  1245.     neg.l    8(SP)
  1246.     negx.l    4(SP)
  1247. sdiv2    eor.b    d4,d7
  1248.     bsr    xdiv
  1249.     tst.b    d7
  1250.     beq    sdiv3
  1251.     neg.l    (SP)
  1252. sdiv3    tst.b    d4
  1253.     beq    sdiv4
  1254.     neg.l    4(SP)
  1255. sdiv4    move.l    (a6)+,-(SP)
  1256.     rts
  1257. slmod    move.l    (SP)+,-(a6)
  1258.     moveq    #0,d1
  1259.     popd0
  1260.     tst.l    (SP)
  1261.     bpl    slmod1
  1262.     subq.l    #1,d1
  1263. slmod1    pushd1
  1264.     pushd0
  1265.     move.l    (a6)+,-(SP)
  1266.     bra.s    sdiv
  1267. *
  1268.     dcode    U*,x,cmove,ustar
  1269.     bsr    mpy
  1270.     gonext
  1271. *
  1272.     dcode    U/,x,ustar,uslash
  1273.     bsr    xdiv
  1274.     gonext
  1275. *
  1276.     dcode    M*,x,uslash,mstar
  1277.     bsr    smpy
  1278.     gonext
  1279. *
  1280.     dcode    M/,x,mstar,mslash
  1281.     bsr    sdiv
  1282.     gonext
  1283. *
  1284.     dcode    */,x,mslash,starsla
  1285.     move.l    (SP)+,-(a6)
  1286.     bsr    smpy
  1287.     move.l    (a6)+,-(SP)
  1288.     bsr    sdiv
  1289.     move.l    (SP)+,(SP)
  1290.     gonext
  1291. *
  1292.     dcode    */MOD,x,starsla,ssmod
  1293.     move.l    (SP)+,-(a6)
  1294.     bsr    smpy
  1295.     move.l    (a6)+,-(SP)
  1296.     bsr    sdiv
  1297.     gonext
  1298. *
  1299.     dcode    M/MOD,x,ssmod,msmod
  1300.     move.l    (SP)+,-(a6)
  1301.     moveq    #0,d0
  1302.     pushd0
  1303.     move.l    (a6),-(SP)
  1304.     bsr    xdiv
  1305.     move.l    (a6)+,d0
  1306.     move.l    (SP)+,-(a6)
  1307.     pushd0
  1308.     bsr    xdiv
  1309.     move.l    (a6)+,-(SP)
  1310.     gonext
  1311. *
  1312.     dcode    *,x,msmod,star    ; *
  1313.     bsr    smpy
  1314.     addq.l    #4,SP    ; drop top of stack
  1315.     gonext
  1316. *
  1317.     dcode    /,x,star,slash    ; /
  1318.     bsr    slmod
  1319.     move.l    (SP)+,(SP)
  1320.     gonext
  1321. *
  1322.     dcode    /MOD,x,slash,xslmod    ; /MOD
  1323.     bsr    slmod
  1324.     gonext
  1325. *
  1326.     dcode    MOD,x,xslmod,mod    ; MOD
  1327.     bsr    slmod
  1328.     addq.l    #4,SP
  1329.     gonext
  1330. *
  1331.     dcode    D>,x,mod,dgrt    ; D>
  1332.     moveq    #1,d0
  1333.     move.l    8(SP),d1
  1334.     cmp.l    (SP),d1
  1335.     bgt    dgrt1
  1336.     move.l    12(SP),d1
  1337.     cmp.l    4(SP),d1
  1338.     bgt    dgrt1
  1339.     moveq    #0,d0
  1340. dgrt1    adda.l    #16,SP
  1341.     pushd0
  1342.     gonext
  1343. *
  1344.     dcode    D<,x,dgrt,dless    ; D<
  1345.     moveq    #1,d0
  1346.     move.l    8(SP),d1
  1347.     cmp.l    (SP),d1
  1348.     blt    dless1
  1349.     move.l    12(SP),d1
  1350.     cmp.l    4(SP),d1
  1351.     blt    dless1
  1352.     moveq    #0,d0
  1353. dless1    adda.l    #16,SP
  1354.     pushd0
  1355.     gonext
  1356. *
  1357.     dcode    D=,x,dless,dequ    ; D=
  1358.     move.l    (SP),d1
  1359.     cmp.l    8(SP),d1
  1360.     seq    d0
  1361.     move.l    4(SP),d1
  1362.     cmp.l    12(SP),d1
  1363.     seq    d1
  1364.     adda.l    #16,SP
  1365.     and.l    d1,d0
  1366.     bra    setbyt
  1367.     gonext
  1368. *
  1369.     dcode    U<,x,dequ,uless
  1370.     cmp2
  1371.     scs    d0
  1372.     bra.s    setbyt
  1373. *
  1374.     dcode    U>,x,uless,ugrt
  1375.     cmp2
  1376.     scc    d0
  1377.     bra.s    setbyt
  1378. *
  1379.     dcode    <,x,ugrt,less    ; <
  1380.     cmp2
  1381.     slt    d0
  1382.     bra.s    setbyt
  1383. *
  1384.     dcode    >,x,less,grt    ; >
  1385.     cmp2
  1386.     sgt    d0
  1387.     bra.s    setbyt
  1388. *
  1389.     dcode    =,x,grt,equals    ; =
  1390.     cmp2
  1391.     seq    d0
  1392.     bra.s    setbyt
  1393. *
  1394.     dcode    <>,x,equals,nequals
  1395.     cmp2
  1396.     sne    d0
  1397.     bra.s    setbyt
  1398. *
  1399.     dcode    0=,x,nequals,zequ
  1400.     tst.l    (SP)+
  1401.     seq    d0
  1402.     bra.s    setbyt
  1403. *
  1404.     dcode    0<,x,zequ,zless
  1405.     tst.l    (SP)+
  1406.     smi    d0
  1407. setbyt    moveq    #1,d1
  1408.     and.l    d1,d0
  1409.     pushD0
  1410.     gonext
  1411. *
  1412.     dcode    0>,x,zless,zgrt
  1413.     tst.l    (SP)+
  1414.     sgt    d0
  1415.     bra.s    setbyt
  1416. *
  1417.     dcode    <=,x,zgrt,lesequ
  1418.     cmp2
  1419.     sle    d0
  1420.     bra.s    setbyt
  1421. *
  1422.     dcode    >=,x,lesequ,grtequ
  1423.     cmp2
  1424.     sge    d0
  1425.     bra.s    setbyt
  1426. *
  1427.     dcode    0!,x,grtequ,zstore    ; store 0 at addr
  1428.     move.l    (sp)+,d7
  1429.     clr.l    0(a3,d7.l)
  1430.     gonext
  1431. *
  1432.     dcode    0,x,zstore,pzer    ; short, fast 0 word
  1433.     clr.l    -(SP)
  1434.     gonext
  1435. *
  1436.     dcode    1,x,pzer,pone    ; short, fast 1 word
  1437.     move.l    #1,-(SP)
  1438.     gonext
  1439. *
  1440.     dcode    -1,x,pone,pmone    ; short, fast -1 word
  1441.     move.l    #-1,-(SP)
  1442.     gonext
  1443. *
  1444.     dcode    2,x,pmone,ptwo    ; short, fast 2 word
  1445.     move.l    #2,-(SP)
  1446.     gonext
  1447. *
  1448.     dcode    4,x,ptwo,pfour
  1449.     move.l    #4,-(SP)
  1450.     gonext
  1451. *
  1452.     dcode    AND,x,pfour,and_
  1453.     popD0
  1454.     and.l    d0,(SP)
  1455.     gonext
  1456. *
  1457.     dcode    LAND,x,and_,land_
  1458.     popd0
  1459.     tst.l    (SP)
  1460.     beq    land2
  1461.     move.l    #1,(SP)
  1462.     tst.l    d0
  1463.     beq    land1
  1464.     moveq    #1,d0
  1465. land1    and.l    d0,(SP)
  1466. land2    gonext
  1467. *
  1468.     dcode    OR,x,land_,or_
  1469.     popD0
  1470.     or.l    d0,(SP)
  1471.     gonext
  1472. *
  1473.     dcode    LOR,x,or_,lor_
  1474.     popd0
  1475.     tst.l    d0
  1476.     beq    lor1
  1477.     moveq    #1,d0
  1478. lor1    tst.l    (SP)
  1479.     beq    lor2
  1480.     move.l    #1,(SP)
  1481. lor2    or.l    d0,(SP)
  1482.     gonext
  1483. *
  1484.     dcode    XOR,x,lor_,xor
  1485.     popD0
  1486.     eor.l    d0,(SP)
  1487.     gonext
  1488. *
  1489.     dcode    LXOR,x,xor,lxor
  1490.     popd0
  1491.     tst.l    d0
  1492.     beq    lxor1
  1493.     moveq    #1,d0
  1494. lxor1    tst.l    (SP)
  1495.     beq    lxor2
  1496.     move.l    #1,(SP)
  1497. lxor2    eor.l    d0,(SP)
  1498.     gonext
  1499. *
  1500.     dcode    HERE,x,lxor,here
  1501.     move.l    #(dp9-origin),d7
  1502.     move.l    0(a3,d7.l),-(SP)
  1503.     gonext
  1504. *
  1505.     dcode    ALLOT,x,here,allot
  1506.     move.l    #(dp9-origin),d7
  1507.     popD0
  1508.     add.l    d0,0(a3,d7.l)    ; increment DP
  1509.     gonext
  1510. *
  1511.     dcode    SP@,x,allot,spfet
  1512.     move.l    SP,d0
  1513.     sub.l    a3,d0
  1514.     pushD0
  1515.     gonext
  1516. *
  1517.     dcode    SP!,x,spfet,spstor
  1518.     move.l    #(s09-origin),d7
  1519.     move.l    0(a3,d7.l),d7
  1520.     lea    0(a3,d7.l),SP    ; add a3 to it and store in SP
  1521.     gonext
  1522. *
  1523.     dcode    RP@,x,spstor,rpfet
  1524.     move.l    a6,d0
  1525.     sub.l    a3,d0
  1526.     pushD0
  1527.     gonext
  1528. *
  1529.     dcode    RP!,x,rpfet,rpstor
  1530.     move.l    #(r09-origin),d7
  1531.     move.l    0(a3,d7.l),d7
  1532.     lea    0(a3,d7.l),a6    ; add a3 to it and store in RP
  1533.     gonext
  1534. *
  1535.     dcode    MP!,x,rpstor,mpstor
  1536.     move.l    initmp(PC),d5
  1537.     add.l    a3,d5    ; get initmp and add a3 to it
  1538.     gonext
  1539. *
  1540.     dcode    MP@,x,mpstor,mpfet
  1541.     move.l    d5,d0
  1542.     sub.l    a3,d0
  1543.     pushD0
  1544.     gonext
  1545. *
  1546.     dcode    THEPORT,x,mpfet,port_
  1547.     move.l    (a5),a0    ; Point to QD globals
  1548.     move.l    (a0),d0    ; point to current grafport
  1549.     sub.l    a3,d0
  1550.     pushd0
  1551.     gonext
  1552. *
  1553.     dcode    (LCWORD),x,port_,lcword    ; doesn't map to upper ca
  1554.     popd0        ; d0=len to next word
  1555.     lea    in9(PC),a0
  1556.     add.l    d0,(a0)    ; bump IN
  1557.     popd0        ; d0=offs to end of parsed word
  1558.     popd1        ; d1=offs to beg of parsed word
  1559.     sub.w    d1,d0    ; d0=len this word
  1560.     lea    dp9(PC),a0
  1561.     movea.l    (a0),a0    ; a0=relative DP
  1562.     adda.l    a3,a0    ; a0=abs DP = HERE
  1563.     move.b    d0,(a0)    ; store len
  1564.     move.b    #32,1(a0,d0.l)    ; blank at end of word
  1565.     movea.l    (SP)+,a1    ; addr of string
  1566.     adda.l    a3,a1
  1567.     adda.l    d1,a1    ; a1=source address to move from
  1568. wMov    move.b    -1(a1,d0.w),0(a0,d0.w)    ; copy the string
  1569.     subq.l    #1,d0
  1570.     bne.s    wMov
  1571.     gonext
  1572. *
  1573.     dcode    (WORD),x,lcword,word_    ; fast code for WORD
  1574.     popd0        ; d0=len to next word
  1575.     lea    in9(PC),a0
  1576.     add.l    d0,(a0)    ; bump IN
  1577.     popd0        ; d0=offs to end of parsed word
  1578.     popd1        ; d1=offs to beg of parsed word
  1579.     sub.w    d1,d0    ; d0=len this word
  1580.     lea    dp9(PC),a0
  1581.     movea.l    (a0),a0    ; a0=relative DP
  1582.     adda.l    a3,a0    ; a0=abs DP = HERE
  1583.     move.b    d0,(a0)    ; store len
  1584.     move.b    #32,1(a0,d0.l)    ; blank at end of word
  1585.     movea.l    (SP)+,a1    ; addr of string
  1586.     adda.l    a3,a1
  1587.     adda.l    d1,a1    ; a1=source address to move from
  1588. wordMov    move.b    -1(a1,d0.w),0(a0,d0.w)    ; copy the string
  1589.     tst.b    ucase9+3-origin(a3)    ; is upper case flag on?
  1590.     beq.s    wordmov1
  1591.     cmpi.b    #96,0(a0,d0.w)
  1592.     ble    wordmov1    ; map to upper case
  1593.     cmpi.b    #123,0(a0,d0.w)
  1594.     bge    wordMov1
  1595.     subi.b    #32,0(a0,d0.w)
  1596. wordmov1    subq.l    #1,d0
  1597.     bne.s    wordMov
  1598.     gonext
  1599. *
  1600.     dcode    (DODO),x,word_,dodo    ; code for mcfa words
  1601. dodo1    move.w    -2(a3,d7.l),d0    ; pickup len to child's pfa
  1602.     add.l    d0,d6    ; advance wp
  1603.     move.l    d6,-(sp)    ; push pfa for do> code
  1604.     suba.l    a3,a4
  1605.     move.l    a4,-(a6)    ; save old IP on RP
  1606.     lea    10(a3,d7.l),a4    ; point IP to threaded code
  1607.     gonext
  1608. *
  1609. ; this code gets compiled before each piece of DO.. code (10 bytes long)
  1610.     dcode    DOJMP,x,dodo,dojmp
  1611.     move.l    #(dodo1-origin),d0
  1612.     jmp    0(a3,d0.l)
  1613. *
  1614. ; this code gets compiled into the front of each class definition
  1615. ; and is pointed to by the cfa of all objects
  1616.     dcode    DOOBJ,x,dojmp,doobj
  1617. obcode    addq.l    #4,d6    ; d6->pfa of object
  1618. dirObj    move.l    d6,-(SP)    ; push obj addr
  1619.     gonext
  1620. *
  1621. ; this is the code pointed to by the cfa of all classes
  1622.     dcode    DOCLASS,x,doobj,dclass
  1623.     addq.l    #4,d6
  1624.     move.l    d6,-(SP)    ; push ^class on stack
  1625.     move.l    #(bldvec-origin),d6    ; d6 has cfa of BLDVEC
  1626.     move.l    0(a3,d6.l),d7    ; d7 has code addr of BLDVEC
  1627.     jmp    0(a3,d7.l)    ; do it
  1628. *
  1629. ; runtime code for a message to a public object
  1630.     dcode    M0CFA,x,dclass,zcfa
  1631.     movea.l    d5,a2
  1632.     clr.l    d0
  1633.     clr.l    d4
  1634.     move.l    (SP)+,d3    ; get obj addr in d3
  1635.     move.b    8(a3,d6.l),d0    ; pickup #args for named stack
  1636.     beq    noArgs
  1637.     addq.l    #2,d6    ; skip extra word for #args in method
  1638.     move.l    d0,d1    ; save #args
  1639.     lsr.b    #4,d0    ; get #temps nybble
  1640.     beq    noLocs    ; no local vars
  1641.     move.l    d0,d4    ; accum total #cells in d4
  1642.     lsl.b    #2,d0    ; compute #bytes = cells*4
  1643.     suba.l    d0,a2    ; allocate temp space
  1644. noLocs    andi.b    #$0f,d1    ; low nybble has #input parms
  1645.     beq    noIns    ; no input parms
  1646.     add.l    d1,d4
  1647. someArgs    move.l    (SP)+,-(a2)    ; pop data stack to methods stack
  1648.     subq.w    #1,d1
  1649.     bne.s    someArgs    ; transfer all args from data stack
  1650. noIns    move.l    d4,d0
  1651. noArgs    move.l    d0,-(a2)    ; push #args to methods stack
  1652.     move.l    d3,-(a2)    ; d3 has base address of local data
  1653.     move.l    a2,d5
  1654.     suba.l    a3,a4    ; Perform colcode
  1655.     move.l    a4,-(a6)
  1656.     addq.l    #8,d6
  1657.     lea    0(a3,d6.l),a4
  1658.     gonext
  1659. *
  1660. ; runtime code for a message to a private ivar
  1661.     dcode    M1CFA,x,zcfa,onecfa
  1662.     move.l    d5,a2
  1663.     clr.l    d0
  1664.     clr.l    d4
  1665.     move.w    (a4)+,d0    ; get offset to ivar
  1666.     bge    notSelf    ; if negative, this is a Self reference
  1667.     clr.l    d0    ; if self, preserve base addr
  1668. notSelf    move.l    (a2),d2    ; get base address
  1669.     add.l    d0,d2    ; add offset to base address
  1670.     clr.w    d0
  1671.     move.b    4(a3,d6.l),d0    ; pickup #args for named stack
  1672.     beq    noArgs1
  1673.     addq.l    #2,d6    ; skip extra word for #args in method
  1674.     move.l    d0,d1    ; save #args
  1675.     lsr.b    #4,d0    ; get #temps nybble
  1676.     beq    nolocs1
  1677.     move.l    D0,D4    ; total #cells
  1678.     lsl.b    #2,d0    ; compute #bytes = cells*4
  1679.     suba.l    d0,a2    ; allocate temp space
  1680. noLocs1    andi.b    #$0f,d1    ; low nybble has #input parms
  1681.     beq    noins1
  1682.     add.l    d1,d4    ; save #input parms
  1683. args1    move.l    (SP)+,-(a2)    ; pop data stack to methods stack
  1684.     subq.w    #1,d1
  1685.     bne.s    args1    ; transfer all args from data stack
  1686. noins1    move.l    d4,d0
  1687. noArgs1    move.l    d0,-(a2)    ; push #args to methods stack
  1688.     move.l    d2,-(a2)    ; push offset+base to mstack
  1689. mNest    move.l    a2,d5
  1690.     suba.l    a3,a4    ; do colcode nest
  1691.     move.l    a4,-(a6)
  1692.     addq.l    #4,d6
  1693.     lea    0(a3,d6.l),a4
  1694.     gonext
  1695. *
  1696.     dcode    (;M),x,onecfa,semim_    ; this is the ;m definition
  1697.     addq.l    #8,d5    ; pop two entries from mstack
  1698.     movea.l    d5,a2
  1699.     move.l    -4(a2),d0    ; look at #args
  1700.     beq    noPop
  1701.     lsl.w    #2,d0    ; setup to add #args*4
  1702.     adda.l    d0,a2    ; pop #args
  1703.     move.l    a2,d5
  1704. noPop    move.l    (a6)+,d7
  1705.     lea    0(a3,d7.l),a4
  1706.     gonext
  1707. *
  1708.     dcode    ;S,x,semim_,semis    ; this is the ;S definition
  1709.     move.l    (a6)+,d7
  1710.     lea    0(a3,d7.l),a4
  1711.     gonext
  1712. *
  1713.     dcode    COLP,x,semis,pcolon    ; named stack colon code
  1714. pcolcode    move.l    d5,a2
  1715.     clr.l    d0
  1716.     clr.l    d4
  1717.     move.b    4(a3,d6.l),d0    ; pickup #args for named stack
  1718.     beq    noArgs3
  1719.     addq.l    #2,d6    ; skip extra word for #args in method
  1720.     move.l    d0,d1    ; save #args
  1721.     lsr.b    #4,d0    ; get #temps nybble
  1722.     beq    noLocs3    ; no local vars
  1723.     move.l    d0,d4    ; accum total #cells in d4
  1724.     lsl.b    #2,d0    ; compute #bytes = cells*4
  1725.     sub.l    d0,a2    ; allocate temp space
  1726. NoLocs3    andi.b    #$0f,D1    ; low nybble has #input parms
  1727.     beq    noIns3    ; no input parms
  1728.     add.l    d1,d4
  1729. Args3    move.l    (SP)+,-(a2)    ; pop data stack to methods stack
  1730.     subq.w    #1,d1
  1731.     bne.s    Args3    ; transfer all args from data stack
  1732. noIns3    move.l    d4,d0
  1733. noArgs3    move.l    d0,-(a2)    ; push #args to methods stack
  1734.     clr.l    -(a2)    ; waste the objaddr cell
  1735.     move.l    a2,d5    ;
  1736.     suba.l    a3,a4    ; Perform colcode
  1737.     move.l    a4,-(a6)
  1738.     addq.l    #4,d6
  1739.     lea    0(a3,d6.l),a4
  1740.     gonext
  1741. *
  1742.     dcode    (SEMIP),x,pcolon,semip    ; named stack denester co
  1743.     addq.l    #8,d5    ; pop two entries from mstack
  1744.     movea.l    d5,a2
  1745.     move.l    -4(a2),d0    ; look at #args
  1746.     beq    noPops1
  1747.     lsl.w    #2,d0    ; setup to add #args*4
  1748.     adda.l    d0,a2    ; pop #args
  1749.     move.l    a2,d5
  1750. nopops1    move.l    (a6)+,d7
  1751.     lea    0(a3,d7.l),a4
  1752.     gonext
  1753. *
  1754.     dcode    LEAVE,x,semip,leave
  1755.     move.l    (a6),4(a6)
  1756.     gonext
  1757. *
  1758.     dcode    >R,x,leave,toR
  1759.     move.l    (SP)+,-(a6)
  1760.     gonext
  1761. *
  1762.     dcode    R>,x,toR,rFrom
  1763.     move.l    (a6)+,-(SP)
  1764.     gonext
  1765. *
  1766.     dcode    R,x,rFrom,r
  1767.     move.l    (a6),-(SP)
  1768.     gonext
  1769. *
  1770.     dcode    PUSHM,x,r,mpush
  1771.     exg    d5,a2
  1772.     move.l    (SP)+,-(a2)
  1773.     exg    d5,a2
  1774.     gonext
  1775. *
  1776.     dcode    POPM,x,mpush,mpop
  1777.     exg    d5,a2
  1778.     move.l    (a2)+,-(SP)
  1779.     exg    d5,a2
  1780.     gonext
  1781. *
  1782.     dcode    COPYM,x,mpop,mcopy
  1783.     move.l    d5,a2
  1784.     move.l    (a2),-(SP)
  1785.     gonext
  1786. *
  1787.     dcode    EXGM,x,mcopy,mexg
  1788.     exg    d5,a2
  1789.     move.l    (SP),d0
  1790.     move.l    (a2),(SP)
  1791.     move.l    d0,(a2)
  1792.     gonext
  1793. *
  1794.     dcode    DUPM,x,mexg,mdup
  1795. dupm    exg    d5,a2
  1796.     move.l    (a2),-(a2)
  1797.     exg    d5,a2
  1798.     gonext
  1799. *
  1800.     dcode    ADDM,x,mdup,madd
  1801.     popd0
  1802. addmd0    exg    d5,a2    ; copied this from nucleus--suspect!
  1803.     add.l    d0,(a2)
  1804.     exg    d5,a2
  1805.     gonext
  1806. *
  1807.     dcode    DROPM,x,madd,mdrop
  1808.     exg    d5,a2    ; *** popmd0
  1809.     move.l    (a2)+,d0
  1810.     exg    d5,a2
  1811.     gonext
  1812. *
  1813.     dcode    MP0,x,mdrop,mp0    ; mstack picks for named parms
  1814.     move.l    d5,a2
  1815.     move.l    8(a2),-(SP)    ; push parm to data stack
  1816.     gonext
  1817. *
  1818.     dcode    MP1,x,mp0,mp1    ; mstack picks for named parms
  1819.     move.l    d5,a2
  1820.     move.l    12(a2),-(SP)    ; push parm to data stack
  1821.     gonext
  1822. *
  1823.     dcode    MP2,x,mp1,mp2    ; mstack picks for named parms
  1824.     move.l    d5,a2
  1825.     move.l    16(a2),-(SP)    ; push parm to data stack
  1826.     gonext
  1827. *
  1828.     dcode    MP3,x,mp2,mp3    ; mstack picks for named parms
  1829.     move.l    d5,a2
  1830.     move.l    20(a2),-(SP)    ; push parm to data stack
  1831.     gonext
  1832. *
  1833.     dcode    MP4,x,mp3,mp4    ; mstack picks for named parms
  1834.     move.l    d5,a2
  1835.     move.l    24(a2),-(SP)    ; push parm to data stack
  1836.     gonext
  1837. *
  1838.     dcode    MP5,x,mp4,mp5    ; mstack picks for named parms
  1839.     move.l    d5,a2
  1840.     move.l    28(a2),-(SP)    ; push parm to data stack
  1841.     gonext
  1842. *
  1843.     dcode    MS0,x,mp5,ms0    ; mstack stores for named parms
  1844.     move.l    d5,a2
  1845.     move.l    (SP)+,8(a2)    ; replace parm val with top of stack
  1846.     gonext
  1847. *
  1848.     dcode    MS1,x,ms0,ms1    ; mstack stores for named parms
  1849.     move.l    d5,a2
  1850.     move.l    (SP)+,12(a2)    ; replace parm val with top of stack
  1851.     gonext
  1852. *
  1853.     dcode    MS2,x,ms1,ms2    ; mstack stores for named parms
  1854.     move.l    d5,a2
  1855.     move.l    (SP)+,16(a2)    ; replace parm val with top of stack
  1856.     gonext
  1857. *
  1858.     dcode    MS3,x,ms2,ms3    ; mstack stores for named parms
  1859.     move.l    d5,a2
  1860.     move.l    (SP)+,20(a2)    ; replace parm val with top of stack
  1861.     gonext
  1862. *
  1863.     dcode    MS4,x,ms3,ms4    ; mstack stores for named parms
  1864.     move.l    d5,a2
  1865.     move.l    (SP)+,24(a2)    ; replace parm val with top of stack
  1866.     gonext
  1867. *
  1868.     dcode    MS5,x,ms4,ms5    ; mstack stores for named parms
  1869.     move.l    d5,a2
  1870.     move.l    (SP)+,28(a2)    ; replace parm val with top of stack
  1871.     gonext
  1872. *
  1873.     dcode    (++>),x,ms5,minc    ; increment named parm
  1874.     move.l    d5,a2
  1875.     move.w    (a4)+,d0    ; get element offset
  1876.     move.l    (sp)+,d1    ; get increment value
  1877.     add.l    d1,0(a2,d0.w)    ; increment the cell
  1878.     gonext
  1879. *
  1880.     dcode    (EX>),x,minc,mdo    ; execute a procedural arg
  1881.     move.l    d5,a2
  1882.     move.w    (a4)+,d0    ; get offset to named parm
  1883.     move.l    0(a2,d0.w),d6    ; get the cfa
  1884.     move.l    0(a3,d6.l),d7    ; get the code
  1885.     jmp    0(a3,d7.l)
  1886. *
  1887.     dcode    +,x,mdo,plus
  1888.     popD0
  1889.     add.l    d0,(SP)
  1890.     gonext
  1891. *
  1892.     dcode    -,x,plus,subt
  1893.     popD0
  1894.     sub.l    d0,(SP)
  1895.     gonext
  1896. *
  1897.     dcode    MAX,x,subt,max
  1898.     popD0
  1899.     cmp.l    (SP),d0
  1900.     blt    maxq
  1901.     move.l    d0,(SP)
  1902. maxq    gonext
  1903. *
  1904.     dcode    MIN,x,max,min
  1905.     popD0
  1906.     cmp.l    (SP),d0
  1907.     bgt    minq
  1908.     move.l    d0,(SP)
  1909. minq    gonext
  1910. *
  1911.     dcode    NEGATE,x,min,minus
  1912. mins1    neg.l    (SP)
  1913.     gonext
  1914. *
  1915.     dcode    DNEGATE,x,minus,dminus
  1916. dmins1    neg.l    4(SP)
  1917.     negx.l    (SP)
  1918.     gonext
  1919. *
  1920.     dcode    CFA,x,dminus,cfa
  1921.     subq.l    #4,(SP)
  1922.     gonext
  1923. *
  1924.     dcode    +-,x,cfa,plmin
  1925.     tst.l    (SP)+
  1926.     bmi.s    mins1
  1927.     gonext
  1928. *
  1929.     dcode    ABS,x,plmin,abs
  1930.     tst.l    (SP)
  1931.     bmi.s    mins1
  1932.     gonext
  1933. *
  1934.     dcode    DABS,x,abs,dabs
  1935.     tst.l    (SP)
  1936.     bmi.s    dmins1
  1937.     gonext
  1938. *
  1939.     dcode    S->D,x,dabs,sToD
  1940.     moveq    #0,d0
  1941.     tst.l    (SP)
  1942.     bpl    GOHERE
  1943.     subq.l    #1,d0
  1944. GOHERE    pushd0
  1945.     gonext
  1946. *
  1947.     dcode    OVER,x,sToD,over
  1948.     move.l    4(SP),-(SP)
  1949.     gonext
  1950. *
  1951.     dcode    2OVER,x,over,over2
  1952.     move.l    12(SP),-(SP)
  1953.     move.l    12(SP),-(SP)
  1954.     gonext
  1955. *
  1956.     dcode    DROP,x,over2,drop
  1957.     addq.l    #4,SP
  1958.     gonext
  1959. *
  1960.     dcode    2DROP,x,drop,drop2
  1961.     addq.l    #8,SP
  1962.     gonext
  1963. *
  1964.     dcode    SWAP,x,drop2,swap_
  1965.     popD0
  1966.     move.l    (SP),d1
  1967.     move.l    d0,(SP)
  1968.     pushD1
  1969.     gonext
  1970. *
  1971.     dcode    2SWAP,x,swap_,swap2
  1972.     popD0
  1973.     popD1
  1974.     move.l    (SP)+,d3
  1975.     move.l    (SP),d4
  1976.     move.l    d1,(SP)
  1977.     move.l    d0,-(SP)
  1978.     move.l    d4,-(SP)
  1979.     move.l    d3,-(SP)
  1980.     gonext
  1981. *
  1982.     dcode    DUP,x,swap2,dup
  1983.     move.l    (SP),-(SP)
  1984.     gonext
  1985. *
  1986.     dcode    2DUP,x,dup,dup2
  1987.     move.l    4(SP),-(SP)
  1988.     move.l    4(SP),-(SP)
  1989.     gonext
  1990. *
  1991.     dcode    -DUP,x,dup2,mindup
  1992.     tst.l    (SP)
  1993.     beq    ddup
  1994.     move.l    (SP),-(SP)
  1995. ddup    gonext
  1996. *
  1997.     dcode    +!,x,mindup,plstor
  1998.     move.l    (SP)+,d7
  1999.     popD0
  2000.     add.l    d0,0(a3,d7.l)
  2001.     gonext
  2002. *
  2003.     dcode    TOGGLE,x,plstor,toggle
  2004.     popD0
  2005.     move.l    (SP)+,d7
  2006.     eor.b    d0,0(a3,d7.l)
  2007.     gonext
  2008. *
  2009.     dcode    W@,x,toggle,wfetch    ; this is a 16-bit fetch
  2010.     clr.l    d0
  2011.     move.l    (SP),d7
  2012.     move.w    0(a3,d7.l),d0
  2013.     move.l    d0,(SP)
  2014.     gonext
  2015. *
  2016.     dcode    @,x,wfetch,fetch    ; this is a 32-bit fetch
  2017.     move.l    (SP),d7
  2018.     move.l    0(a3,d7.l),(SP)
  2019.     gonext
  2020. *
  2021.     dcode    C@,x,fetch,cfetch
  2022.     clr.l    d0
  2023.     move.l    (SP),d7
  2024.     move.b    0(a3,d7.l),d0
  2025.     move.l    d0,(SP)
  2026.     gonext
  2027. *
  2028.     dcode    MW@,x,cfetch,mwfetch    ; 16-bit fetch from mstack addr
  2029.     move.l    d5,a2
  2030.     clr.l    d0
  2031.     move.l    (a2),d7
  2032.     move.w    0(a3,d7.l),d0
  2033.     ext.l    d0    ; sign-extend
  2034.     move.l    d0,-(SP)
  2035.     gonext
  2036. *
  2037.     dcode    M@,x,mwfetch,mfetch    ; this is a 32-bit fetch
  2038.     move.l    d5,a2
  2039.     move.l    (a2),d7
  2040.     move.l    0(a3,d7.l),-(SP)
  2041.     gonext
  2042. *
  2043.     dcode    2@,x,mfetch,fetch2    ; ( double word fetch )
  2044.     move.l    (SP),d7
  2045.     lea    0(a3,d7.l),a0
  2046.     move.l    (a0)+,-(sp)
  2047.     move.l    (a0),4(SP)
  2048.     gonext
  2049. *
  2050.     dcode    W!,x,fetch2,wstore    ; 16-bit store
  2051.     move.l    (SP)+,d7    ; address is relative to a3
  2052.     popD0        ; d0 has value
  2053.     move.w    d0,0(a3,d7.l)
  2054.     gonext
  2055. *
  2056.     dcode    W+!,x,wstore,wpstore    ; 16-bit plus store
  2057.     move.l    (SP)+,d7
  2058.     popD0
  2059.     add.w    d0,0(a3,d7.l)
  2060.     gonext
  2061. *
  2062.     dcode    !,x,wpstore,store    ; 32-bit store
  2063.     move.l    (SP)+,d7    ; address is relative to a3
  2064.     popD0        ; d0 has value
  2065.     move.l    d0,0(a3,d7.l)
  2066.     gonext
  2067. *
  2068.     dcode    C!,x,store,cstore
  2069.     move.l    (SP)+,d7
  2070.     popD0
  2071.     move.b    d0,0(a3,d7.l)
  2072.     gonext
  2073. *
  2074.     dcode    C+!,x,cstore,cpstore    ; 8 bit plus store
  2075.     move.l    (SP)+,d7
  2076.     popD0
  2077.     add.b    d0,0(a3,d7.l)
  2078.     gonext
  2079. *
  2080.     dcode    MW!,x,cpstore,mwstore    ; 16-bit store to addr on mstack
  2081.     move.l    d5,a2
  2082.     move.l    (a2),d7    ; address is relative to a3
  2083.     popD0        ; d0 has value
  2084.     move.w    d0,0(a3,d7.l)
  2085.     gonext
  2086. *
  2087.     dcode    M!,x,mwstore,mstore    ; 32-bit store to addr on mstack
  2088.     move.l    d5,a2
  2089.     move.l    (a2),d7    ; address is relative to a3
  2090.     popD0        ; d0 has value
  2091.     move.l    d0,0(a3,d7.l)
  2092.     gonext
  2093. *
  2094.     dcode    2!,x,mstore,store2    ; ( double word store )
  2095.     move.l    (SP)+,d7
  2096.     lea    0(a3,d7.l),a0
  2097.     move.l    (SP)+,(a0)+
  2098.     move.l    (SP)+,(a0)
  2099.     gonext
  2100. *
  2101.     dcode    D+,x,store2,dplus    ; 64-bit add
  2102.     popd0
  2103.     popd1
  2104.     move.l    (SP)+,d2
  2105.     move.l    (sp)+,d3
  2106.     add.l    d1,d3
  2107.     addx.l    d0,d2
  2108.     move.l    d3,-(SP)
  2109.     move.l    d2,-(SP)
  2110.     gonext
  2111. *
  2112.     dcode    1+,x,dplus,plus1
  2113.     addq.l    #1,(SP)
  2114.     gonext
  2115. *
  2116.     dcode    2+,x,plus1,plus2
  2117.     addq.l    #2,(SP)
  2118.     gonext
  2119. *
  2120.     dcode    3+,x,plus2,plus3
  2121.     addq.l    #3,(SP)
  2122.     gonext
  2123. *
  2124.     dcode    4+,x,plus3,plus4
  2125.     addq.l    #4,(SP)
  2126.     gonext
  2127. *
  2128.     dcode    8+,x,plus4,plus8
  2129.     addq.l    #8,(SP)
  2130.     gonext
  2131. *
  2132.     dcode    1-,x,plus8,min1
  2133.     subq.l    #1,(SP)
  2134.     gonext
  2135. *
  2136.     dcode    2-,x,min1,min2
  2137.     subq.l    #2,(SP)
  2138.     gonext
  2139. *
  2140.     dcode    4-,x,min2,min4
  2141.     subq.l    #4,(SP)
  2142.     gonext
  2143. *
  2144.     dcode    8-,x,min4,min8
  2145.     subq.l    #8,(SP)
  2146.     gonext
  2147. *
  2148.     dcode    2*,x,min8,times2
  2149.     move.l    (SP),d0
  2150.     asl.l    #1,d0
  2151.     move.l    d0,(SP)
  2152.     gonext
  2153. *
  2154.     dcode    4*,x,times2,times4
  2155.     move.l    (SP),d0
  2156.     asl.l    #2,d0
  2157.     move.l    d0,(SP)
  2158.     gonext
  2159. *
  2160.     dcode    8*,x,times4,times8
  2161.     move.l    (SP),d0
  2162.     asl.l    #3,d0
  2163.     move.l    d0,(SP)
  2164.     gonext
  2165. *
  2166.     dcode    2/,x,times8,xdiv2
  2167.     move.l    (SP),d0
  2168.     asr.l    #1,d0
  2169.     move.l    d0,(SP)
  2170.     gonext
  2171. *
  2172. ; ^elem expects base addr on mstack, and an index on pstack
  2173.     dcode    (^ELEM),x,xdiv2,pelem    ; return address of array eleme
  2174.     move.l    d5,a2    ; pickup base address on mstack
  2175.     move.l    (a2),d7    ; base of object in d7
  2176.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2177.     clr.l    d1
  2178.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2179.     add.l    d1,d7    ; d7 points to idx hdr
  2180.     move.w    0(a3,d7.l),d1    ; fetch width word from header
  2181.     mulu    2(SP),d1    ; multiply index * width
  2182.     add.l    d1,d7    ; add to base address
  2183.     addq.l    #4,d7    ; skip the header
  2184.     move.l    d7,(SP)    ; leave on data stack
  2185.     gonext
  2186. *
  2187.     dcode    IDXBASE,x,pelem,idxbas    ; idx addr of indexed object
  2188.     move.l    d5,a2    ; pickup base address on mstack
  2189.     move.l    (a2),d7    ; base of object in d7
  2190.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2191.     clr.l    d1
  2192.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2193.     add.l    d1,d7    ; d7 points to idx hdr
  2194.     addq.l    #4,d7    ; skip the idx hdr
  2195.     move.l    d7,-(SP)    ; leave the ^ixdata
  2196.     gonext
  2197. *
  2198.     dcode    LIMIT,x,idxbas,limit    ; limit of indexed object
  2199.     move.l    d5,a2    ; pickup base address on mstack
  2200.     move.l    (a2),d7    ; base of object in d7
  2201.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2202.     clr.l    d1
  2203.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2204.     add.l    d1,d7    ; d7 points to idx hdr
  2205.     move.w    2(a3,d7.l),-(SP)    ; leave the limit
  2206.     clr.w    -(SP)
  2207.     gonext
  2208. *
  2209.     dcode    RANGE?,x,limit,qrange    ; index out of range?
  2210.     move.l    d5,a2    ; pickup base address on mstack
  2211.     move.l    (a2),d7    ; base of object in d7
  2212.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2213.     clr.l    d1
  2214.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2215.     add.l    d1,d7    ; d7 points to idx hdr
  2216.     clr.l    d0
  2217.     move.w    2(a3,d7.l),d0    ; get the limit
  2218.     cmp.l    (SP),d0    ; is limit > index?
  2219.     sle    d1    ; true if out of range
  2220.     neg.b    d1    ; forth boolean
  2221.     move.l    d1,-(SP)
  2222.     gonext
  2223. *
  2224.     dcode    AT1,x,qrange,at1    ; at opt for byte elements
  2225.     move.l    d5,a2    ; pickup base address on mstack
  2226.     move.l    (a2),d7    ; base of object in d7
  2227.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2228.     clr.l    d1
  2229.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2230.     add.l    d1,d7    ; d7 points to idx hdr
  2231.     add.l    (SP)+,d7    ; add the index
  2232.     clr.l    d0
  2233.     move.b    4(a3,d7.l),d0    ; fetch addr+4 (for idx hdr)
  2234.     move.l    d0,-(SP)
  2235.     gonext
  2236. *
  2237.     dcode    AT2,x,at1,at2    ; at opt for byte elements
  2238.     move.l    d5,a2    ; pickup base address on mstack
  2239.     move.l    (a2),d7    ; base of object in d7
  2240.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2241.     clr.l    d1
  2242.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2243.     add.l    d1,d7    ; d7 points to idx hdr
  2244.     move.l    (SP),d0    ; get the index
  2245.     lsl.w    #1,d0    ; index * 2
  2246.     add.l    d0,d7    ; add the index
  2247.     move.w    4(a3,d7.l),d1    ; fetch addr+4 (for idx hdr)
  2248.     ext.l    d1    ; sign extend
  2249.     move.l    d1,(sp)
  2250.     gonext
  2251. *
  2252.     dcode    AT4,x,at2,at4    ; at opt for long elements
  2253.     move.l    d5,a2    ; pickup base address on mstack
  2254.     move.l    (a2),d7    ; base of object in d7
  2255.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2256.     clr.l    d1
  2257.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2258.     add.l    d1,d7    ; d7 points to idx hdr
  2259.     move.l    (SP)+,d0    ; get the index
  2260.     lsl.w    #2,d0    ; index * 4
  2261.     add.l    d0,d7    ; add the index
  2262.     move.l    4(a3,d7.l),-(SP)    ; fetch addr+4 (for idx hdr)
  2263.     gonext
  2264. *
  2265.     dcode    TO1,x,at4,to1    ; To opt for byte elements
  2266.     move.l    d5,a2    ; pickup base address on mstack
  2267.     move.l    (a2),d7    ; base of object in d7
  2268.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2269.     clr.l    d1
  2270.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2271.     add.l    d1,d7    ; d7 points to idx hdr
  2272.     add.l    (SP)+,d7    ; add the index
  2273.     move.l    (SP)+,d0
  2274.     move.b    d0,4(a3,d7.l)    ; store to addr+4 (for idx hdr)
  2275.     gonext
  2276. *
  2277.     dcode    TO2,x,to1,to2    ; To opt for byte elements
  2278.     move.l    d5,a2    ; pickup base address on mstack
  2279.     move.l    (a2),d7    ; base of object in d7
  2280.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2281.     clr.l    d1
  2282.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2283.     add.l    d1,d7    ; d7 points to idx hdr
  2284.     move.l    (SP)+,d0    ; get the index
  2285.     lsl.w    #1,d0    ; index * 2
  2286.     add.l    d0,d7    ; add the index
  2287.     move.l    (sp)+,d1
  2288.     move.w    d1,4(a3,d7.l)    ; store to addr+4 (for idx hdr)
  2289.     gonext
  2290. *
  2291.     dcode    TO4,x,to2,to4    ; to opt for long elements
  2292.     move.l    d5,a2    ; pickup base address on mstack
  2293.     move.l    (a2),d7    ; base of object in d7
  2294.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2295.     clr.l    d1
  2296.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2297.     add.l    d1,d7    ; d7 points to idx hdr
  2298.     move.l    (SP)+,d0    ; get the index
  2299.     lsl.w    #2,d0    ; index * 4
  2300.     add.l    d0,d7    ; add the index
  2301.     move.l    (SP)+,4(a3,d7.l)    ; store to addr+4 (for idx hdr)
  2302.     gonext
  2303. *
  2304.     dcode    ++4,x,to4,inc4    ; inc opt for long elements
  2305.     move.l    d5,a2    ; pickup base address on mstack
  2306.     move.l    (a2),d7    ; base of object in d7
  2307.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2308.     clr.l    d1
  2309.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2310.     add.l    d1,d7    ; d7 points to idx hdr
  2311.     move.l    (SP)+,d0    ; get the index
  2312.     lsl.w    #2,d0    ; index * 4
  2313.     add.l    d0,d7    ; add the index
  2314.     move.l    (SP)+,d1    ; get increment
  2315.     add.l    d1,4(a3,d7.l)    ; inc addr+4 (for idx hdr)
  2316.     gonext
  2317. *
  2318.     dcode    ++2,x,inc4,inc2    ; inc opt for word elements
  2319.     move.l    d5,a2    ; pickup base address on mstack
  2320.     move.l    (a2),d7    ; base of object in d7
  2321.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2322.     clr.l    d1
  2323.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2324.     add.l    d1,d7    ; d7 points to idx hdr
  2325.     move.l    (SP)+,d0    ; get the index
  2326.     lsl.w    #1,d0    ; index * 4
  2327.     add.l    d0,d7    ; add the index
  2328.     move.l    (SP)+,d1    ; get increment
  2329.     add.w    d1,4(a3,d7.l)    ; inc addr+4 (for idx hdr)
  2330.     gonext
  2331. *
  2332.     dcode    ++1,x,inc2,inc1    ; inc opt for byte elements
  2333.     move.l    d5,a2    ; pickup base address on mstack
  2334.     move.l    (a2),d7    ; base of object in d7
  2335.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2336.     clr.l    d1
  2337.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2338.     add.l    d1,d7    ; d7 points to idx hdr
  2339.     move.l    (SP)+,d0    ; get the index
  2340.     add.l    d0,d7    ; add the index
  2341.     move.l    (SP)+,d1    ; get increment
  2342.     add.b    d1,4(a3,d7.l)    ; inc addr+4 (for idx hdr)
  2343.     gonext
  2344. *
  2345. ; fast left lshift ( val #shift -- val )
  2346.     dcode    <<,x,inc1,shfl
  2347.     popd0
  2348.     popd1
  2349.     lsl.l    d0,d1
  2350.     move.l    d1,-(SP)
  2351.     gonext
  2352. *
  2353. ; fast right lshift ( val #shift -- val )
  2354.     dcode    >>,x,shfl,shfr
  2355.     popd0
  2356.     popd1
  2357.     lsr.l    d0,d1
  2358.     move.l    d1,-(SP)
  2359.     gonext
  2360. *
  2361.     dcode    (ABS),x,shfr,abs_    ; leave absolute of mstack addr
  2362.     move.l    d5,a2
  2363.     move.l    (a2),d0
  2364.     add.l    a3,d0
  2365.     move.l    d0,-(SP)
  2366.     gonext
  2367. *
  2368.     dcode    COUNT,x,abs_,count
  2369.     move.l    (SP),d0
  2370.     add.l    #1,(SP)
  2371.     clr.l    d1
  2372.     move.b    0(A3,d0.l),d1
  2373.     move.l    d1,-(SP)
  2374.     gonext
  2375. *
  2376.     dcode    DEPTH,x,count,depth
  2377.     move.l    SP,d0
  2378.     sub.l    a3,d0
  2379.     move.l    #(s09-origin),d7
  2380.     sub.l    0(a3,d7.l),d0
  2381.     neg.l    d0
  2382.     asr.l    #2,d0
  2383.     pushD0
  2384.     gonext
  2385. *
  2386.     dcode    FILL,x,depth,fil
  2387.     popD0
  2388. fill1    popD1
  2389.     move.l    (SP)+,d7
  2390.     lea    0(a3,d7.l),a0
  2391. fil1    subq.l    #1,d1
  2392.     bmi    fil2
  2393.     move.b    d0,(a0)+
  2394.     bra.s    fil1
  2395. fil2    gonext
  2396. *
  2397.     dcode    ERASE,x,fil,era
  2398.     clr.l    d0
  2399.     bra.s    fill1
  2400. *
  2401.     dcode    BLANKS,x,era,blanks
  2402.     moveq    #$20,d0
  2403.     bra.s    fill1
  2404. *    
  2405.     dcode    +BASE,x,blanks,basadr
  2406.     move.l    (SP)+,d7
  2407.     pea    0(a3,d7.l)    ; push absolute address = base+pa
  2408.     gonext
  2409. *
  2410.     dcode    -BASE,x,basadr,minbas
  2411.     move.l    a3,d0
  2412.     sub.l    d0,(SP)
  2413.     gonext
  2414. *
  2415.     dcode    ROT,x,minbas,rot
  2416.     popD0
  2417.     popD1
  2418.     move.l    (SP),d2
  2419.     move.l    d1,(SP)
  2420.     pushD0
  2421.     move.l    d2,-(SP)
  2422.     gonext
  2423. *
  2424.     dcode    PICK,x,rot,pick
  2425.     move.l    (SP),d0
  2426.     asl.l    #2,d0    ; index * 4
  2427.     move.L    0(SP,d0.w),(SP)
  2428.     gonext
  2429. *
  2430.     dcode    RESET,x,pick,rset    ; reboot the machine
  2431.     reset
  2432. *
  2433.     dcode    (FDOS),x,rset,fdos    ; general file system trap call
  2434.     lea    fdtrap(PC),a0    ; stack : (pblock trap --- result)
  2435.     clr.l    d1
  2436.     move.w    (SP)+,d1    ; function selector to d0 later
  2437.     move.w    (SP)+,(a0)    ; move in trap#
  2438.     movea.l    (SP)+,a0    ; file control block
  2439.     adda.l    a3,a0    ; make it absolute
  2440.     tst.b    hwpavail9+3-origin(a3)    ; flush cache if necessary
  2441.     beq.s    fdt0
  2442.     moveq    #1,d0
  2443.     _HWPriv
  2444. fdt0    move.l    d1,d0    ; restore d0
  2445. fdtrap    DC.W    0    ; call Toolbox
  2446.     move.w    ioResult(a0),d0    ; leave result on stack
  2447.     ext.l    d0
  2448.     pushd0
  2449.     gonext
  2450. *
  2451.     dcode    (MAKE),x,fdos,make_
  2452.     move.l    (SP)+,a0    ; parm block offset in a0
  2453.     add.l    a3,a0    ; make it absolute
  2454.     _Hcreate        ; call Toolbox
  2455.     move.w    ioResult(a0),d0    ; leave result on stack
  2456.     ext.l    d0
  2457.     pushd0
  2458.     gonext
  2459. *
  2460.     dcode    (OPEN),x,make_,open_
  2461.     popd0        ; get access mode in d0
  2462.     move.l    (SP)+,a0    ; parm block offset in a0
  2463.     add.l    a3,a0    ; make it absolute
  2464.     move.b    d0,ioPermssn(a0)    ; set i/o permission
  2465.     _Hopen        ; open the file
  2466.     move.w    ioResult(a0),d0    ; leave result on stack
  2467.     ext.l    d0
  2468.     pushd0
  2469.     gonext
  2470. *
  2471.     dcode    (CLOSE),x,open_,close_
  2472.     move.l    (SP)+,a0    ; parm block offset in a0
  2473.     add.l    a3,a0    ; make it absolute
  2474.     _close        ; call Toolbox CLOSE
  2475.     move.w    ioResult(a0),d0    ; leave result on stack
  2476.     ext.l    d0
  2477.     pushd0
  2478.     gonext
  2479. *
  2480.     dcode    (DELETE),x,close_,delet_
  2481.     move.l    (SP)+,a0    ; parm block offset in a0
  2482.     add.l    a3,a0    ; make it absolute
  2483.     _delete        ; call Toolbox DELETE
  2484.     move.w    ioResult(a0),d0    ; leave result on stack
  2485.     ext.l    d0
  2486.     pushd0
  2487.     gonext
  2488. *
  2489.     dcode    (READ),x,delet_,read_
  2490.     popD0        ; pop buffer address into d0
  2491.     add.l    a3,d0    ; make it absolute
  2492.     popD1        ; get count in d1
  2493.     move.l    (SP)+,a0    ; parm block offset in a0
  2494.     add.l    a3,a0    ; make it absolute
  2495.     move.l    d0,iobuffer(a0)    ; store buffer pointer in parm block
  2496.     move.l    d1,ioReqCount(a0)    ; store count in parm block
  2497.     _read        ; call Toolbox read
  2498.     move.w    ioResult(a0),d0    ; leave result on stack
  2499.     ext.l    d0
  2500.     pushd0
  2501.     gonext
  2502. *
  2503.     dcode    (WRITE),x,read_,write_
  2504.     popD0        ; pop buffer address into d0
  2505.     add.l    a3,d0    ; make it absolute
  2506.     popD1        ; get count in d1
  2507.     move.l    (SP)+,a0    ; parm block offset in a0
  2508.     add.l    a3,a0    ; make it absolute
  2509.     move.l    d0,iobuffer(a0)    ; store buffer pointer in parm block
  2510.     move.l    d1,ioReqCount(a0)    ; store count in parm block
  2511.     _write        ; call Toolbox read
  2512.     move.w    ioResult(a0),d0    ; leave result on stack
  2513.     ext.l    d0
  2514.     pushD0
  2515.     gonext
  2516. *
  2517.     dcode    (LSEEK),x,write_,lseek
  2518.     popD0        ; pickup position offset in D0
  2519.     popD1        ; pickup positioning mode in D1
  2520.     move.l    (SP)+,a0    ; pop pba
  2521.     add.l    a3,a0
  2522.     move.l    d0,ioPosOffset(a0)    ; set offset in parm block
  2523.     move.w    d1,ioPosMode(a0)    ; set mode in parm block
  2524.     _SetFPos
  2525.     move.w    ioResult(a0),d0    ; leave result on stack
  2526.     ext.l    d0
  2527.     pushd0
  2528.     gonext
  2529. *
  2530. ; ------- (;CODE) is needed by the following words
  2531.     dcol    (;CODE),x,lseek,pscode
  2532.     cfas    rfrom,latest,pfa,cfa,store,semis
  2533. *
  2534. ; ------- The following words are ;CODE type words
  2535.     dcol    CONSTANT,x,pscode,const
  2536.     cfas    kreate,comma
  2537.     scode        ; points to (;CODE)
  2538. concode    addq.l    #4,d6    ; runtime code for constant
  2539.     move.l    0(a3,d6.l),-(SP)
  2540.     gonext
  2541. *
  2542.     dcol    :,I,const,colon    ; this colon doesn't set Context
  2543.     cfas    qexec,stcsp    ; to Current.
  2544.     cfas    kreate,rbrak
  2545.     scode
  2546. colcode    suba.l    a3,a4    ; convert absolute address to offset
  2547.     move.l    a4,-(a6)    ; push current IP to Return stack
  2548.     addq.l    #4,d6    ; advance WP to pfa of word being def.
  2549.     lea    0(a3,d6.l),a4    ; get absolute addr in A4
  2550.     gonext
  2551. *
  2552.     dcol    DOES>,x,colon,does
  2553.     cfas    rfrom,latest,pfa
  2554.     DATA    store-origin
  2555.     scode
  2556. doescode    addq.l    #4,d6
  2557.     suba.l    a3,a4
  2558.     move.l    a4,-(a6)
  2559.     move.l    0(a3,d6.l),d7
  2560.     lea    0(a3,d7.l),a4
  2561.     addq.l    #4,d6
  2562.     move.l    d6,-(SP)
  2563.     gonext
  2564. *
  2565.     dcol    VARIABLE,x,does,varb
  2566.     cfas    const
  2567.     scode
  2568. varcode    addq.l    #4,d6
  2569.     move.l    d6,-(SP)
  2570.     gonext
  2571. *
  2572.     dcode    OBJMP,x,varb,objmp
  2573.     move.l    #(obcode-origin),d0    ; get addr of object code
  2574.     jmp    0(a3,d0.l)    ; obj puts its addr on stack
  2575. *
  2576.     dcol    (AB"),x,objmp,abq_    ; abort" runtime word
  2577.     cfas    mindup
  2578.     eif.    abq11
  2579.     cfas    cr,lit,10+origin,beep,here,count,type
  2580.     cfas    lit,63+origin,emit,space,R,count,type,abort
  2581.     else.    abq11
  2582.     cfas    rfrom,count,plus,aline,tor
  2583.     ethen.    abq11
  2584.     cfas    semis
  2585. *
  2586.     dcol    PREFIX,x,abq_,prefix    ; prefix builder for mcfa
  2587.     cfas    builds,times4,wcomma,immed
  2588.     cfas    does
  2589. dopref    cfas    fetpfa
  2590.     cfas    cfa,over,wfetch,plus
  2591.     cfas    swap_,min4,over,fetch,lit,6+origin,subt
  2592.     cfas    fetch,subt,abq_
  2593.     STR    "invalid prefix "
  2594.     cfas    state
  2595.     if.    pre11
  2596.     cfas    comma,semis
  2597.     then.    pre11
  2598.     cfas    exec,semis
  2599. *
  2600. ; execute 1cfa of object vector ivar
  2601.     dcode    X1CFA,x,prefix,x1cfa
  2602.     move.l    d5,a2    ; 1cfa is the fetch/deferred exec routine
  2603.     clr.l    d6
  2604.     move.w    (a4)+,d6    ; get offset to ivar
  2605.     add.l    (a2),d6    ; add base addr to get 1cfa addr in WP
  2606.     move.l    0(a3,d6.l),d7    ; get code addr in d7
  2607.     jmp    0(a3,d7.l)
  2608. *
  2609.     dcol    VOCABULARY,x,x1cfa,vocab
  2610.     cfas    builds
  2611.     mlit    $8120
  2612.     cfas    wcomma,currnt,min2,comma,here,vocl,comma
  2613.     cfas    vocl2,does
  2614. dovocab    cfas    plus2,contxt2,semis
  2615. *
  2616. ; define prefixes for 3cfa variables,vects
  2617.     ddoes    PUT,I,vocab,preput,dopref    ; 2cfa for all
  2618.     DC.W    8
  2619.     ddoes    PUTDEF,I,preput,prputd,dopref    ; 1cfa for sysVe
  2620.     DC.W    4
  2621. ; define code handlers for 3cfa variables,vects
  2622.     DATA    0    ; fetch code for sysvect
  2623.     DC.W    8    ; len to vect's pfa from 1cfa
  2624. dofetchv    addq.l    #8,d6    ; advance wp to pfa
  2625.     move.l    0(a3,d6.l),-(SP)    ; get contents of pfa
  2626.     gonext
  2627. *
  2628.     DATA    preput+4-origin    ; store code
  2629.     DC.W    4    ; len to vect's pfa from 1cfa
  2630. dostore    addq.l    #4,d6    ; advance wp to pfa
  2631.     move.l    (SP)+,0(a3,d6.l)    ; get contents of pfa
  2632.     gonext
  2633. *
  2634.     DATA    0    ; increment code
  2635.     DC.W    8    ; len to vect's pfa from 1cfa
  2636. doincr    addq.l    #8,d6    ; advance wp to pfa
  2637.     popd0
  2638.     add.l    d0,0(a3,d6.l)    ; increment contents of pfa
  2639.     gonext
  2640. *
  2641.     DC.W    12
  2642. doexec    add.l    #12,d6
  2643.     move.l    0(a3,d6.l),d6    ; get address to execute
  2644.     move.l    0(a3,d6.l),d7    ; get contents of CFA
  2645.     jmp    0(a3,d7.l)    ; execute the code
  2646.     DC.W    12    ; execute a system vector table entry
  2647. dosexec    add.l    #12,d6
  2648.     move.l    userdp(PC),d0    ; rel base of system vector table
  2649.     add.l    0(a3,d6.l),d0    ; add offset into table
  2650.     move.l    0(a3,d0.l),d1    ; get vector contents
  2651.     beq    dodeflt    ; if 0, exec default
  2652.     move.l    d1,d6
  2653.     bra.s    sexec
  2654. dodeflt    move.l    4(a3,d6.l),d6    ; get default cfa to execute
  2655. sexec    move.l    0(a3,d6.l),d7    ; get contents of CFA
  2656.     jmp    0(a3,d7.l)    ; execute the code
  2657. *
  2658.     DATA    prputd+4-origin
  2659.     DC.W    8    ; set offset, default for system vector
  2660. doputdef    addq.l    #8,d6
  2661.     move.l    (SP)+,0(a3,d6.l)    ; set the offset
  2662.     move.l    (SP)+,4(a3,d6.l)    ; set the default
  2663.     gonext
  2664. *
  2665.     DATA    preput+4-origin
  2666.     DC.W    4    ; set sys vector table entry for this vect
  2667. doputsv    addq.l    #4,d6
  2668.     move.l    userdp(PC),d0
  2669.     add.l    0(a3,d6.l),d0    ; add the offset
  2670.     move.l    (SP)+,0(a3,d0.l)    ; store the vector
  2671.     gonext
  2672. *
  2673.     DC.W    12    ; len to value's pfa from 1cfa
  2674. dofetch    add.l    #12,d6    ; advance wp to pfa
  2675.     move.l    0(a3,d6.l),-(SP)    ; get contents of pfa
  2676.     gonext
  2677. *
  2678.     dcol    ",",x,prputd,comma    ; begin comman dict entry
  2679.     cfas    here,store,pfour,allot,semis
  2680. *
  2681.     dcol    "W,",x,comma,wcomma    ; begin Wcomma dict entry
  2682.     cfas    here,wstore,lit,2+origin,allot,semis
  2683. *
  2684.     dcol    "C,",x,wcomma,ccomma    ; begin C, dict entry
  2685.     cfas    here,cstore,pone,allot,semis
  2686. *
  2687.     dcol    @PFA,x,ccomma,fetpfa
  2688.     cfas    mfind,zequ,abq_
  2689.     STR    "not found  "
  2690.     cfas    drop,semis
  2691. *
  2692.     dcol    LFA,x,fetpfa,lfa
  2693.     mlit    8
  2694.     cfas    subt,semis
  2695. *
  2696.     dcol    NFA,x,lfa,nfa
  2697.     mlit    9
  2698.     cfas    subt
  2699.     mlit    -1
  2700.     cfas    traver,semis
  2701. *
  2702.     dcol    PFA,x,nfa,pfa
  2703.     mlit    1
  2704.     cfas    traver,lit,9+origin,plus,semis
  2705. *
  2706.     dcol    >LINE,x,pfa,toline
  2707.     cfas    docs
  2708.     if.    L100
  2709.     cfas    min2
  2710.     then.    L100
  2711.     cfas    semis
  2712. *
  2713.     dcol    LINE>,x,toline,linefm
  2714.     cfas    docs
  2715.     if.    L101
  2716.     cfas    plus2
  2717.     then.    L101
  2718.     cfas    semis
  2719. *
  2720.     dcol    ALIGN,x,linefm,aline
  2721.     cfas    dup
  2722.     mlit    1
  2723.     cfas    and_,plus,semis
  2724. *
  2725.     dcol    DECIMAL,x,aline,decim
  2726.     mlit    $0a
  2727.     cfas    base2,semis
  2728. *
  2729.     dcol    HEX,x,decim,hex
  2730.     mlit    $10
  2731.     cfas    base2,semis
  2732. *
  2733.     dcol    (."),x,hex,dotq_
  2734.     cfas    r,count,dup,plus1,aline,rfrom,plus,toR,type
  2735.     cfas    semis
  2736. *
  2737.     dcol    PAD,x,dotq_,pad
  2738.     mlit    padbuf-origin
  2739.     cfas    semis
  2740. *
  2741.     dcol    #>,x,pad,enum
  2742.     cfas    drop2,hld,pad,over,subt,semis
  2743. *
  2744.     dcol    HOLD,x,enum,hold
  2745.     DATA    pmone-origin
  2746.     cfas    hld1,hld,cstore,semis
  2747. *
  2748.     dcol    SIGN,x,hold,sign
  2749.     cfas    rot,zless
  2750.     if.    Z3
  2751.     mlit    $2d
  2752.     cfas    hold
  2753.     then.    Z3
  2754.     cfas    semis
  2755. *
  2756.     dcol    #,x,sign,sharp
  2757.     cfas    base,msmod,rot
  2758.     mlit    9
  2759.     cfas    over,less
  2760.     if.    Z4
  2761.     mlit    7
  2762.     cfas    plus
  2763.     then.    Z4
  2764.     mlit    $30
  2765.     cfas    plus,hold,semis
  2766. *
  2767.     dcol    #S,x,sharp,sharps
  2768.     begin.    Z5
  2769.     cfas    sharp,dup2,or_,zequ
  2770.     until.    Z5
  2771.     cfas    semis
  2772. *
  2773.     dcol    <#,x,sharps,snum
  2774.     cfas    pad,hld2,semis
  2775. *
  2776.     dcol    D.R,x,snum,ddotr
  2777.     cfas    toR,swap_,over,dabs,snum,sharps,sign,enum,rfrom
  2778.     cfas    over,subt,spaces,type,semis
  2779. *
  2780.     dcol    D.,x,ddotr,ddot
  2781.     mlit    0
  2782.     cfas    ddotr,space,semis
  2783. *
  2784.     dcol    .,x,ddot,dot
  2785.     cfas    sToD,ddot,semis
  2786. *
  2787.     dcol    U.,x,dot,udot
  2788.     mlit    0
  2789.     cfas    ddot,semis
  2790. *
  2791.     dcol    .R,x,udot,dotR
  2792.     cfas    toR,sToD,rfrom,ddotr,semis
  2793. *
  2794.     dcol    ?,x,dotR,quest
  2795.     cfas    fetch,dot,semis
  2796. *
  2797.     dcol    SPACE,x,quest,space
  2798.     cfas    bl,emit,semis
  2799. *
  2800.     dcol    SPACES,x,space,spaces
  2801.     mlit    0
  2802.     do.    Z7
  2803.     cfas    bl,emit
  2804.     loop.    Z7
  2805.     cfas    semis
  2806. *
  2807.     dcol    -TRAILING,x,spaces,mtrail
  2808.     cfas    dup
  2809.     mlit    0
  2810.     do.    Z8
  2811.     cfas    over,over,plus,min1,cfetch,bl,subt
  2812.     eif.    Z10
  2813.     cfas    leave
  2814.     else.    Z10
  2815.     cfas    min1
  2816.     ethen.    Z10
  2817.     loop.    Z8
  2818.     cfas    semis
  2819. *
  2820.     dcol    N>COUNT,x,mtrail,ncount
  2821.     cfas    count
  2822.     mlit    $1f
  2823.     cfas    and_,semis
  2824. *
  2825.     dcol    ID.,x,ncount,iddot
  2826.     cfas    ncount,type,space,semis
  2827. *
  2828.     dcol    EMIT,x,iddot,emit
  2829.     cfas    dup,emitvec,pemitv,pone     ; send the char via Quickdraw
  2830.     cfas    out1,semis
  2831. *
  2832.     dcol    TYPE,x,emit,type
  2833.     cfas    dup,out1,dup2,typevec,ptypev,semis
  2834.     dcol    CR,x,type,cr
  2835.     cfas    crvec,pcrvec,semis
  2836. *
  2837.     dcol    CONTBOT,x,cr,contbot
  2838.     cfas    port_,lit,windowsize+origin,plus,plus4
  2839.     cfas    wfetch,semis
  2840. *
  2841.     dcol    CONTTOP,x,contbot,conttop
  2842.     cfas    port_,lit,windowsize+origin,plus
  2843.     cfas    wfetch,semis
  2844. *
  2845.     dcol    ?LEAD,x,conttop,qlead    ; return proper leading for fo
  2846.     cfas    port_,lit,txsize+origin,plus,wfetch
  2847.     cfas    lit,120+origin,star,lit,50+origin,plus    ; Increase 120 f
  2848.     cfas    lit,100+origin,slash,semis
  2849. *
  2850.     dcol    ?LINES,x,qlead,qlines    ; number of even lines in port
  2851.     cfas    qlead,contbot,conttop    ; bottom-top of content rgn
  2852.     cfas    subt,lit,5+origin,subt,    ; less first line location
  2853.     cfas    over,plus1,subt    ; minus ?LEAD+1
  2854.     cfas    swap_,slash,semis    ; divided by ?LEAD
  2855. *
  2856.     dcol    BOTTOM,x,qlines,scrbot    ; coordinate of screen bottom
  2857.     cfas    conttop,plus4,qlead,qlines,star,plus
  2858.     cfas    semis
  2859. *
  2860.     dcol    (CR),x,scrbot,cr_    ; simulate a CR in Quickdraw
  2861.     cfas    dotcur,fetxy,swap_,drop,lit,8+origin,swap_
  2862.     cfas    dup,scrbot,grt
  2863.     eif.    x27
  2864.     cfas    pzer,qlead,minus,scroll,gotoxy
  2865.     else.    x27
  2866.     cfas    qlead,plus
  2867.     cfas    gotoxy
  2868.     ethen.    x27
  2869.     cfas    dotcur,semis
  2870. *
  2871.     dcol    (BS),x,cr_,bs_
  2872.     cfas    dotcur,fetxy,swap_,lit,6+origin,subt,lit,8+origin,max
  2873.     cfas    swap_,dup2,gotoxy,curs_,pzer,curs_2
  2874.     cfas    bl,emit,curs_2,gotoxy,dotcur,semis
  2875. *
  2876.     dcol    ?TERMINAL,x,bs_,qterm
  2877.     cfas    lit,$28+origin,qevt,semis
  2878. *
  2879.     dcol    (KEY),x,qterm,key_
  2880.     mlit    $2A        ; kbd and mouse events
  2881.     cfas    getevt,lit,2+origin,grt
  2882.     eif.    Z100
  2883.     cfas    ftemsg,lit,$00ff+origin,and_
  2884.     else.    Z100
  2885.     cfas    pmone
  2886.     ethen.    Z100
  2887.     cfas    semis
  2888. *
  2889.     dcol    (DKEY),x,key_,dkey_
  2890.     cfas    ufcb,pone,lit,ftwork    ; read 1 char from disk
  2891.     cfas    read_,dup,dkerr2
  2892.     eif.    y10
  2893.     cfas    keystor,pone,curs_2    ; restore to terminal if err
  2894.     cfas    lit,13+origin
  2895.     else.    y10
  2896.     cfas    lit,ftwork,cfetch    ; leav char on stack
  2897.     ethen.    y10
  2898.     cfas    qpause,semis
  2899. *
  2900.     dcol    KEY!,x,dkey_,keystor    ; reset KEY to keyboard
  2901.     cfas    lit,key_,keyvec2,semis
  2902. *
  2903.     dcol    KEY,x,keystor,key
  2904.     cfas    keyvec,semis    ; vectored key
  2905. *
  2906.     dcol    <",x,key,diskin    ; set to disk key inpu
  2907.     cfas    ufcb,close_,dot    ; close the oldfile
  2908.     cfas    lit,useFcb,lit,80+origin,era,pzer,curs_2
  2909.     cfas    lit,34+origin,word,here,dup,cfetch,plus1
  2910.     cfas    lit,useFname,swap_,cmove
  2911.     cfas    lit,useFname,basadr,lit,useFcb,sflptr
  2912.     cfas    ufcb,pone,open_,dot
  2913.     cfas    cr,lit,dkey_,keyvec2,semis
  2914. *
  2915. ; ------------ Disk words for FORTH screen handling
  2916.     dcol    !FPTR,x,diskin,sflptr    ; ( ^fname pblock -- )
  2917.     cfas    lit,18+origin,plus,store,semis
  2918. *
  2919.     dcol    ?COMP,x,sflptr,qcomp
  2920.     cfas    state,zequ,abq_
  2921.     STR    "compilation only "
  2922.     cfas    semis
  2923. *
  2924.     dcol    ?DP,x,qcomp,qdp    ; dp grown into heap?
  2925.     cfas    room,pone,less,abq_
  2926.     STR    " out of room "
  2927.     cfas    semis
  2928. *
  2929.     dcol    ?STACK,x,qdp,qstack
  2930.     cfas    spfet,s0,swap_,uless
  2931.     cfas    abq_
  2932.     STR    "empty stack  "
  2933.     cfas    semis
  2934. *
  2935.     dcol    ?EXEC,x,qstack,qexec
  2936.     cfas    state,cstate,or_,abq_    ; err if class or forth compile
  2937.     STR    "run state only "
  2938.     cfas    semis
  2939. *
  2940.     dcol    ?PAIRS,x,qexec,qpairs
  2941.     cfas    subt,abq_
  2942.     STR    "unpaired conditionals  "
  2943.     cfas    semis
  2944. *
  2945.     dcol    ?CSP,x,qpairs,qcsp
  2946.     cfas    spfet,csp,subt,abq_
  2947.     STR    "definition not finished  "
  2948.     cfas    semis
  2949. *
  2950.     dcol    (NUMBER),x,qcsp,num_
  2951.     begin.    Z27
  2952.     cfas    plus1,dup,tor,cfetch,base,digit
  2953.     while.    Z27
  2954.     cfas    swap_,base,ustar,drop,rot,base
  2955.     cfas    ustar,dplus,dpl,plus1
  2956.     if.    Z28
  2957.     cfas    pone,dpl1
  2958.     then.    Z28
  2959.     cfas    rfrom
  2960.     repeat.    Z27
  2961.     cfas    rfrom,semis
  2962. *
  2963.     dcol    ?NUM,x,num_,qnum    ; ( addr -- d t OR f )
  2964.     cfas    pzer,pzer,rot,dup,plus1,cfetch
  2965.     mlit    $2d
  2966.     cfas    equals,dup,tor,plus,pmone
  2967.     begin.    Z30
  2968.     cfas    dpl2,num_,dup,cfetch,bl,subt
  2969.     while.    Z30
  2970.     cfas    dup,cfetch,lit,$2e+origin,subt
  2971.     if.    zz177
  2972.     cfas    rfrom,drop2,drop2,pzer,semis
  2973.     then.    zz177
  2974.     cfas    pzer
  2975.     repeat.    Z30
  2976.     cfas    drop,rfrom
  2977.     if.    Z31
  2978.     cfas    dminus
  2979.     then.    Z31
  2980.     cfas    pone,semis
  2981. *
  2982.     dcol    NUMBER,x,qnum,number    ; ( addr -- d )
  2983.     cfas    qnum,zequ,abq_
  2984.     STR    "not found  "
  2985.     cfas    semis
  2986. *
  2987.     dcol    LITERAL,I,number,liter
  2988.     cfas    state
  2989.     if.    Z32
  2990.     cfas    dup,lit
  2991.     DATA    $10000
  2992.     cfas    less,over,zless,zequ,and_
  2993.     eif.    zz39
  2994.     cfas    comp,wlit,wcomma
  2995.     else.    zz39
  2996.     cfas    comp,lit,comma    ; builds word lit if n>=0 and n<$10000
  2997.     ethen.    zz39
  2998.     then.    Z32
  2999.     cfas    semis
  3000. *
  3001.     dcol    EXPECT,x,liter,expect
  3002.     cfas    over,plus,over
  3003.     do.    Z33
  3004.     cfas    key,dup,lit,8+origin,equals    ; bs ?
  3005.     eif.    Z34
  3006.     cfas    drop,dup,i,equals,dup,rfrom,min2,plus,tor
  3007.     eif.    Z35
  3008.     cfas    lit,10+origin,beep
  3009.     else.    Z35
  3010.     cfas    bs_
  3011.     ethen.    Z35
  3012.     cfas    pzer
  3013.     else.    Z34
  3014.     cfas    dup,zequ
  3015.     if.    y118
  3016.     cfas    drop,lit,32+origin    ; map null to space
  3017.     then.    y118
  3018.     cfas    dup,lit,$0d+origin,equals
  3019.     eif.    Z36
  3020.     cfas    leave,drop,pzer,pzer,cr
  3021.     else.    Z36
  3022.     cfas    dup
  3023.     ethen.    Z36
  3024.     cfas    r,cstore,pzer,r,plus1,cstore
  3025.     ethen.    Z34
  3026.     cfas    echovec
  3027.     loop.    Z33
  3028.     cfas    drop,semis
  3029. *
  3030.     dcol    WORD,x,expect,word
  3031.     cfas    tib
  3032.     cfas    in,plus,swap_,enclos
  3033.     cfas    word_,semis
  3034. *
  3035.     dcol    WORD",x,word,wordq    ; lower-case version of word
  3036.     cfas    tib,in,plus,lit,34+origin,enclos
  3037.     cfas    lcword,here,semis
  3038. *
  3039.     dcol    FIND,x,wordq,mfind
  3040.     cfas    bl,word,ufind,dup,zequ
  3041.     if.    w72
  3042.     cfas    drop,here,contxt,fetch
  3043.     cfas    find_,dup,zequ
  3044.     if.    Z38
  3045.     cfas    contxt,currnt,subt
  3046.     if.    Z40
  3047.     cfas    drop,here,latest,find_
  3048.     then.    Z40
  3049.     then.    Z38
  3050.     then.    w72
  3051.     cfas    semis
  3052. *
  3053.     ADJST        ; X - null word
  3054. lkx    DC.B    $C1
  3055.     DC.B    $00
  3056.     DATA    lkmfind-origin
  3057.     DATA    colcode-origin    ; not Fig standard -
  3058.     cfas    rfrom,drop    ; note: doesn't support Forth screens
  3059.     cfas    semis
  3060. *
  3061.     dcol    "S,",x,x,scomma    ; begin S, dict entry
  3062.     cfas    here,dup,cfetch,plus1,dup
  3063.     cfas    allot,pone,and_
  3064.     if.    sc10
  3065.     cfas    pzer,ccomma
  3066.     then.    sc10
  3067.     cfas    dup,rot,toggle,semis
  3068. *
  3069.     dcol    (CREATE),x,scomma,creat_
  3070.     cfas    here,pone,and_
  3071.     if.    Z430
  3072.     cfas    pzer,ccomma
  3073.     then.    Z430
  3074.     cfas    docs
  3075.     if.    Z410
  3076.     cfas    line_,wcomma
  3077.     then.    Z410
  3078.     cfas    mfind
  3079.     if.    Z420
  3080.     cfas    drop,nfa,iddot,dotq_
  3081.     STR    "is redefined "
  3082.     cfas    cr
  3083.     then.    Z420
  3084.     cfas    lit,$80+origin,scomma
  3085.     cfas    latest,comma,currnt
  3086.     cfas    store,here,plus4,comma,semis
  3087. *
  3088.     dcol    (INTRP),x,creat_,intrp_
  3089.     begin.    Z43
  3090.     cfas    mfind
  3091.     eif.    Z44
  3092.     cfas    state,less
  3093.     eif.    Z45
  3094.     cfas    cfa,comma
  3095.     else.    Z45
  3096.     cfas    cfa,exec
  3097.     ethen.    Z45
  3098.     else.    Z44
  3099.     cfas    here,number,dpl,plus1
  3100.     eif.    Z46
  3101.     cfas    dliter
  3102.     else.    Z46
  3103.     cfas    drop,liter
  3104.     ethen.    Z46
  3105.     ethen.    Z44
  3106.     cfas    qdp,qstack
  3107.     again.    Z43
  3108.     cfas    semis
  3109. *
  3110.     dcol    !CSP,x,intrp_,stcsp
  3111.     cfas    spfet,csp2,semis
  3112. *
  3113.     dcol    QUERY,x,stcsp,query
  3114.     cfas    tib,lit,$99+origin
  3115.     cfas    expvec,pzer,in2,semis
  3116. *
  3117.     dcol    <[,I,query,lbrak
  3118.     mlit    0
  3119.     cfas    state2,semis
  3120. *
  3121.     dcol    ]>,x,lbrak,rbrak
  3122.     mlit    $c0
  3123.     cfas    state2,semis
  3124. *
  3125.     dcol    DEFINITIONS,x,rbrak,defs
  3126.     cfas    contxt,currnt2,semis
  3127. *
  3128.     dcol    <BUILDS,x,defs,builds
  3129.     mlit    0
  3130.     cfas    const,semis
  3131. *
  3132.     dcol    OK,x,builds,ok
  3133.     cfas    depth,ptwo,dotr,base,dup
  3134.     cfas    lit,10+origin,equals
  3135.     eif.    xx11
  3136.     cfas    lit,45+origin,emit
  3137.     else.    xx11
  3138.     cfas    dup,lit,16+origin,equals
  3139.     eif.    xx12
  3140.     cfas    lit,36+origin,emit
  3141.     else.    xx12
  3142.     cfas    lit,63+origin,emit
  3143.     ethen.    xx12
  3144.     ethen.    xx11
  3145.     cfas    drop,lit,62+origin,emit
  3146.     cfas    semis
  3147. *
  3148.     dcode    Q,x,ok,q_
  3149.     clr.w    -(sp)
  3150.     _hilitemenu
  3151.     gonext
  3152. *
  3153.     dcol    QUIT,x,ok,quit
  3154.     cfas    pzer,in2
  3155.     cfas    lbrak,quvec,q_
  3156.     cfas    cr,ok
  3157.     begin.    Z48
  3158.     cfas    qdp,rpstor,query,interp,state,zequ
  3159.     if.    Z50
  3160.     cfas    ok
  3161.     then.    Z50
  3162.     again.    Z48
  3163.     cfas    semis
  3164. *
  3165.     dcol    BACK,x,quit,back
  3166.     cfas    here,subt,comma,semis
  3167. *
  3168.     dcol    FWD,x,back,fwd    ; fill in fwd branch
  3169.     cfas    here,over,subt,swap_,store,semis
  3170. *
  3171.     dcol    BEGIN,I,fwd,begin
  3172.     cfas    qcomp,here,pone,semis
  3173. *
  3174.     dcol    THEN,I,begin,then
  3175.     cfas    qcomp,lit,2+origin,qpairs,fwd,semis
  3176. *
  3177.     dcol    DO,I,then,do    ; compiles fwd branch for smart exit
  3178.     cfas    comp,do_,here,pzer,comma,lit,3+origin,semis
  3179. *
  3180.     dcol    LOOP,I,do,loop
  3181.     cfas    lit,3+origin,qpairs,comp,loop_,dup,plus4,back
  3182.     cfas    fwd,semis
  3183. *
  3184.     dcol    +LOOP,I,loop,ploop
  3185.     cfas    lit,3+origin,qpairs,comp,ploop_,dup,plus4,back
  3186.     cfas    fwd,semis
  3187. *
  3188.     dcol    COMPILE,x,ploop,comp
  3189.     cfas    qcomp,rfrom,dup,plus4
  3190.     cfas    tor,fetch,comma,semis
  3191.     dcol    [COMPILE],I,comp,bcomp
  3192.     cfas    fetpfa,cfa,comma,semis
  3193. *
  3194.     dcol    DLITERAL,I,bcomp,dliter
  3195.     cfas    state
  3196.     if.    Z51
  3197.     cfas    swap_,liter,liter
  3198.     then.    Z51
  3199.     cfas    semis
  3200. *
  3201.     dcol    UNTIL,I,dliter,until
  3202.     cfas    pone,qpairs,comp,bran0,back,semis
  3203. *
  3204.     dcol    AGAIN,I,until,again
  3205.     cfas    pone,qpairs,comp,bran,back,semis
  3206. *
  3207.     dcol    REPEAT,I,again,repeat
  3208.     cfas    tor,tor,again,rfrom,rfrom,min2
  3209.     cfas    then,semis
  3210. *
  3211.     dcol    IF,I,repeat,xif
  3212.     cfas    comp,bran0,here,pzer,comma,lit,2+origin,semis
  3213. *
  3214.     dcol    ELSE,I,xif,xelse
  3215.     cfas    lit,2+origin,qpairs,comp,bran,here,pzer,comma
  3216.     cfas    swap_,lit,2+origin,then,lit,2+origin,semis
  3217. *
  3218.     dcol    WHILE,I,xelse,while
  3219.     cfas    xif,plus2,semis
  3220. *
  3221.     dcol    EXIT,I,while,exit
  3222.     cfas    latest,pfa,cfa,fetch    ; is this a pcolon def?
  3223.     cfas    lit,pcolcode,equals
  3224.     eif.    se10
  3225.     cfas    comp,semip    ; yes, put in parm denester
  3226.     else.    se10
  3227.     cfas    comp,semis
  3228.     ethen.    se10
  3229.     cfas    semis
  3230. *
  3231.     dcol    ;,I,exit,semi    ; immediate - semicolon def
  3232.     cfas    qcsp,exit,lbrak,semis
  3233. *
  3234.     dcol    .",I,semi,dotq
  3235.     cfas    state
  3236.     eif.    Z52
  3237.     cfas    comp,dotq_
  3238.     cfas    wordq    ; lower-case word
  3239.     cfas    cfetch,plus1,aline,allot
  3240.     else.    Z52
  3241.     cfas    wordq,count,type
  3242.     ethen.    Z52
  3243.     cfas    semis
  3244. *
  3245.     dcol    IMMEDIATE,x,dotq,immed
  3246.     cfas    latest,lit,$40+origin,toggle,semis
  3247. *
  3248.     dcol    LATEST,x,immed,latest
  3249.     cfas    currnt,fetch,semis
  3250. *
  3251.     dcol    (,I,latest,lparen
  3252.     cfas    lit,$29+origin,word,semis
  3253. *
  3254.     ADJST    
  3255. lktick    DC.B    $c1    ; tick
  3256.     DC.B    $27
  3257.     DATA    lklparen-origin
  3258. tick    DATA    colcode-origin
  3259.     cfas    fetpfa,liter,semis
  3260. *
  3261.     dcol    FORGET,x,tick,forget
  3262.     cfas    defs    ; set current to context
  3263.     cfas    tick,dup,fence,uless,abq_
  3264.     STR    "in protected dictionary  "
  3265.     cfas    dup,nfa,dp2,lfa,fetch,currnt    ; leave line# if sources on
  3266.     cfas    store,semis    ; otherwise might forget nec stuff
  3267. *
  3268.     dcol    ROOM,x,forget,room    ; leave dict space left
  3269.     cfas    msiz,fetch,dp,bdp,fetch
  3270.     cfas    subt,subt,semis
  3271. *
  3272.     dcol    GREET,x,room,greet
  3273.     cfas    cls
  3274.     mlit    hello-origin
  3275.     cfas    count,type,cr
  3276.     mlit    bytesleft-origin
  3277.     cfas    count,type
  3278.     cfas    room,dot,cr,semis
  3279. *
  3280.     dcol    COLD,x,greet,xcold
  3281.     cfas    lit,aregn,fetch,zequ
  3282.     if.    w59
  3283.     cfas    intool    ; only if we haven't gotten heap already
  3284.     then.    w59
  3285.     cfas    lit,inits0,fetch,s02,lit,initr0,fetch,r02
  3286.     cfas    lit,initfenc,fetch,fence2,lit,initvocl,fetch,vocl2
  3287.     cfas    lit,initdp,fetch,dp2,lit,initmp,fetch,m02
  3288.     cfas    lit,initlast,fetch,lit,forth_
  3289.     cfas    lit,$0a+origin,plus,store,decim,spstor,mpstor    \ careful on the 0a
  3290.     cfas    forth_,defs,pzer,warn2,objini,greet,quit,semis
  3291. *
  3292.     dcol    .PAUSE,x,xcold,dpause
  3293.     cfas    lit,pausemsg,count,type,semis
  3294. *
  3295.     dcol    ?PAUSE,x,dpause,qpause    ; check if user wants to stop
  3296.     cfas    qterm
  3297.     if.    w43
  3298.     cfas    key_,drop,cr,dpause
  3299.     cfas    key_,cr,lit,0+origin,out2,lit,32+origin,grt
  3300.     if.    w44
  3301.     cfas    abort
  3302.     then.    w44
  3303.     then.    w43
  3304.     cfas    semis
  3305. *
  3306.     dcol    ABORT,x,qpause,abort
  3307.     cfas    cr
  3308.     cfas    spstor,mpstor,lit,key_,keyvec2,decim
  3309.     cfas    pone,curs_2,qstack,lbrak,forth_
  3310.     cfas    defs,abvec
  3311.     cfas    lit,$a850+origin,trap_    ; initCursor
  3312.     cfas    quit,semis
  3313. *
  3314.     ddoes    YERK,x,abort,forth_,dovocab    ; FORTH vocabulary
  3315.     DC.W    $8120
  3316. vlf    DATA    lastdef-origin
  3317.     DATA    0
  3318. *
  3319.     dcol    .VAL,x,forth_,dotval
  3320.     cfas    dotr,lit,2+origin,spaces,semis
  3321. *
  3322.     dcol    ?CFA,x,dotval,qcfa
  3323.     cfas    dup,plus4,nfa,ncount
  3324.     cfas    tor,r,plus,plus4,aline
  3325.     cfas    over,equals,rfrom,land_,semis
  3326. *
  3327.     dcol    (.STACK),x,qcfa,dstak_
  3328.     cfas    base,lit,ftwork1,store,dup2,grt    ; preserve current base
  3329.     eif.    z61
  3330.     do.    z62
  3331.     cfas    cr,ifetch,dup,decim
  3332.     cfas    lit,8+origin,dotval,dup,hex,lit,36+origin,emit
  3333.     cfas    pzer,lit,6+origin,ddotr
  3334.     cfas    lit,3+origin,spaces,aline,min4,plus1,false
  3335.     eif.    z63
  3336.     cfas    plus4,nfa,iddot
  3337.     else.    z63
  3338.     cfas    drop
  3339.     ethen.    z63
  3340.     cfas    pfour
  3341.     ploop.    z62
  3342.     else.    z61
  3343.     cfas    lit,emptymsg,count,type,less
  3344.     cfas    abq_
  3345.     STR    "Stack Underflow  "
  3346.     ethen.    z61
  3347.     cfas    lit,ftwork1,fetch,base2,cr    restore base
  3348.     cfas    semis
  3349. *
  3350. Lastdef    dcol    .S,x,dstak_,dots
  3351.     cfas    spfet,s0,swap_,lit,dsmsg
  3352.     cfas    count,type,dstak_,r0,rpfet,lit,rsmsg
  3353.     cfas    count,type,dstak_,m0,mpfet,lit,msmsg
  3354.     cfas    count,type,dstak_
  3355.     cfas    semis
  3356. *
  3357. nextdef    EQU    *
  3358.     ENDR
  3359. *
  3360.     SEG    0,32,VAR.LEN,$20
  3361. SEG0
  3362. SEG_1    JP    start,1
  3363.     JP    getInstL,1
  3364. END_1
  3365. SEG_2    JP    origin,2
  3366.     JP    coldvec,2
  3367.     JP    getDict,2
  3368. END_2
  3369. END0
  3370.     ENDR
  3371. *
  3372. *    END
  3373.     RSRC    YERK,0,32
  3374.     STR     "Yerk Version 3.6.4"
  3375.     ENDR
  3376. *
  3377.     RSRC    FREF,128,32
  3378.     ASC    'APPL'
  3379.     DATA    /0
  3380.     STR    ""
  3381.     ENDR
  3382. *
  3383.     RSRC    FREF,129,32
  3384.     ASC    'COM '
  3385.     DATA    /1
  3386.     STR    ""
  3387.     ENDR
  3388. *
  3389.     RSRC    FREF,130,32
  3390.     ASC 'USER'
  3391.     DATA /2
  3392.     STR    ""
  3393.     ENDR
  3394. *
  3395.     RSRC    FREF,131,32
  3396.     ASC    'BIN '
  3397.     DATA /3
  3398.     STR    ""
  3399.     ENDR
  3400. *
  3401.     RSRC    FREF,132,32
  3402.     ASC    'TEXT'
  3403.     DATA /4
  3404.     STR    ""
  3405.     ENDR
  3406. *
  3407.     RSRC    ICN#,128,32
  3408.     HEX    71c0.0000.cb20.0000
  3409.     HEX    c620.0000.6040.0000
  3410.     HEX    3080.0000.1900.1f80
  3411.     HEX    1900.2040.197e.4020
  3412.     HEX    1981.9810.1e8e.e408
  3413.     HEX    0ccf.3f87.3069.1803
  3414.     HEX    c864.8003.c864.4003
  3415.     HEX    c8c8.f003.c99f.8ff3
  3416.     HEX    c981.990f.c9ff.9903
  3417.     HEX    c8fd.8200.c801.8400
  3418.     HEX    c801.8200.c801.91ce
  3419.     HEX    c801.9939.c801.9f32
  3420.     HEX    c801.d724.c800.e308
  3421.     HEX    c800.0304.cfff.e322
  3422.     HEX    c000.1331.c000.1339
  3423.     HEX    ffff.e3ef.7fff.c1c6
  3424. *
  3425.     HEX    71c0.0000.fbe0.0000
  3426.     HEX    ffe0.0000.7fc0.0000
  3427.     HEX    3f80.0000.1f00.1f80
  3428.     HEX    1f00.3fc0.1f7e.7fe0
  3429.     HEX    1fff.fff0.1ffe.e7f8
  3430.     HEX    0fff.ffff.3ff9.ffff
  3431.     HEX    fffc.ffff.fffc.7fff
  3432.     HEX    fff8.ffff.ffff.ffff
  3433.     HEX    ffff.ff0f.ffff.ff03
  3434.     HEX    ffff.fe00.ffff.fc00
  3435.     HEX    ffff.fe00.ffff.ffce
  3436.     HEX    ffff.ffff.ffff.fffe
  3437.     HEX    ffff.fffc.ffff.fff8
  3438.     HEX    ffff.fffc.ffff.fffe
  3439.     HEX    ffff.ffff.ffff.c1ff
  3440.     HEX    ffff.c1ef.7fff.c1c6
  3441.     ENDR
  3442. *
  3443.     RSRC    ICN#,129,32
  3444.     HEX    71c7.fffe.cb2c.0001
  3445.     HEX    c62c.0001.604f.fff9
  3446.     HEX    3087.fff9.1900.0019
  3447.     HEX    1900.0019.197e.0019
  3448.     HEX    1981.0019.1e8e.0019
  3449.     HEX    0ccc.0019.3068.0019
  3450.     HEX    c864.0019.c864.0019
  3451.     HEX    c8c8.fc19.c99f.8219
  3452.     HEX    c981.9919.c9ff.9919
  3453.     HEX    c8fd.821f.c801.840e
  3454.     HEX    c801.8200.c801.91ce
  3455.     HEX    c801.9939.c801.9f32
  3456.     HEX    c801.d724.c800.e308
  3457.     HEX    c800.0304.cfff.e322
  3458.     HEX    c000.1331.c000.1339
  3459.     HEX    ffff.e3ef.7fff.c1c6
  3460. *
  3461.     HEX    71c7.fffe.fbef.ffff
  3462.     HEX    ffef.ffff.7fcf.ffff
  3463.     HEX    3fff.ffff.1fff.ffff
  3464.     HEX    1fff.ffff.1fff.ffff
  3465.     HEX    1fff.ffff.1fff.ffff
  3466.     HEX    0fff.ffff.3fff.ffff
  3467.     HEX    ffff.ffff.ffff.ffff
  3468.     HEX    ffff.ffff.ffff.ffff
  3469.     HEX    ffff.ffff.ffff.ffff
  3470.     HEX    ffff.ffff.ffff.ffff
  3471.     HEX    ffff.fff8.ffff.ffff
  3472.     HEX    ffff.ffff.ffff.ffff
  3473.     HEX    ffff.fffe.ffff.fffc
  3474.     HEX    ffff.fffc.ffff.fffe
  3475.     HEX    ffff.f3ff.ffff.f3ff
  3476.     HEX    ffff.e3ef.7fff.c1c6
  3477.     ENDR
  3478. *
  3479.     RSRC    ICN#,130,32
  3480.     HEX    71c7.fffe.cb2c.0001
  3481.     HEX    c62c.0001.604f.fff9
  3482.     HEX    3087.fff9.1900.0019
  3483.     HEX    1900.0019.1900.0019
  3484.     HEX    1900.0019.1e00.0019
  3485.     HEX    0c00.0019.3000.0019
  3486.     HEX    c800.0019.c800.0019
  3487.     HEX    c800.0019.c800.0019
  3488.     HEX    c800.0019.c800.0019
  3489.     HEX    c800.001f.c800.000f
  3490.     HEX    c800.0000.c800.01ce
  3491.     HEX    c800.0339.c800.0332
  3492.     HEX    c800.0324.c800.0308
  3493.     HEX    c800.0304.cfff.e322
  3494.     HEX    c000.1331.c000.1339
  3495.     HEX    ffff.e3cf.7fff.c1c6
  3496. *
  3497.     HEX    71c7.fffe.fbef.ffff
  3498.     HEX    ffef.ffff.7fff.ffff
  3499.     HEX    3fff.ffff.1fff.ffff
  3500.     HEX    1fff.ffff.1fff.ffff
  3501.     HEX    1fff.ffff.1fff.ffff
  3502.     HEX    0fff.ffff.3fff.ffff
  3503.     HEX    7fff.ffff.ffff.ffff
  3504.     HEX    ffff.ffff.ffff.ffff
  3505.     HEX    ffff.ffff.ffff.ffff
  3506.     HEX    ffff.ffff.ffff.ffff
  3507.     HEX    ffff.fffe.ffff.ffff
  3508.     HEX    ffff.ffff.ffff.ffff
  3509.     HEX    ffff.fffe.ffff.fffc
  3510.     HEX    ffff.fffc.ffff.fffe
  3511.     HEX    ffff.ffff.ffff.f3ff
  3512.     HEX    ffff.e3ef.7fff.c1c6
  3513.     ENDR
  3514. *
  3515.     RSRC    ICN#,131,32
  3516.     HEX    71c7.fffe.cb2c.0001
  3517.     HEX    c62c.0001.604f.fff9
  3518.     HEX    3087.fff9.1900.0019
  3519.     HEX    1900.0019.1900.0019
  3520.     HEX    1909.1899.1e09.2499
  3521.     HEX    0c09.2499.0009.1899
  3522.     HEX    7000.0019.c800.0019
  3523.     HEX    c989.2319.ca49.2499
  3524.     HEX    ca49.2499.c989.2319
  3525.     HEX    c800.001f.c800.000f
  3526.     HEX    c988.c000.ca49.21ce
  3527.     HEX    ca49.2339.c988.c332
  3528.     HEX    c800.0324.c800.0308
  3529.     HEX    c800.0304.cfff.f322
  3530.     HEX    c000.0b31.c000.0b39
  3531.     HEX    ffff.f3cf.7fff.e1c6
  3532. *
  3533.     HEX    71c7.fffe.fbef.ffff
  3534.     HEX    ffef.ffff.7fff.ffff
  3535.     HEX    3fff.ffff.1fff.ffff
  3536.     HEX    1fff.ffff.1fff.ffff
  3537.     HEX    1fff.ffff.1fff.ffff
  3538.     HEX    0fff.ffff.0fff.ffff
  3539.     HEX    7fff.ffff.ffff.ffff
  3540.     HEX    ffff.ffff.ffff.ffff
  3541.     HEX    ffff.ffff.ffff.ffff
  3542.     HEX    ffff.ffff.ffff.ffff
  3543.     HEX    ffff.fffe.ffff.ffff
  3544.     HEX    ffff.ffff.ffff.ffff
  3545.     HEX    ffff.fffe.ffff.fffc
  3546.     HEX    ffff.fffc.ffff.fffe
  3547.     HEX    ffff.ffff.ffff.ffff
  3548.     HEX    ffff.f7ff.7fff.e7ce
  3549.     ENDR
  3550. *
  3551.     RSRC    ICN#,132,32
  3552.     HEX    71c7.fffe.cb2c.0001
  3553.     HEX    c62c.0001.604f.fff9
  3554.     HEX    3087.fff9.1900.0019
  3555.     HEX    197f.0019.1900.0019
  3556.     HEX    190f.f019.1e00.0019
  3557.     HEX    0c0f.f019.0000.0019
  3558.     HEX    7001.fc19.c800.0019
  3559.     HEX    c87f.fc19.c800.0019
  3560.     HEX    c80f.8019.c800.0019
  3561.     HEX    c87f.fe19.c800.001f
  3562.     HEX    c80f.f000.c800.01ce
  3563.     HEX    c803.c339.c800.0332
  3564.     HEX    c8ff.c324.c800.0308
  3565.     HEX    c800.0304.cfff.e332
  3566.     HEX    c000.1339.c000.133d
  3567.     HEX    ffff.f3cf.7fff.e1c6
  3568. *
  3569.     HEX    638f.fffe.f7cf.ffff
  3570.     HEX    ffcf.ffff.7fff.ffff
  3571.     HEX    3fff.ffff.1fff.ffff
  3572.     HEX    1fff.ffff.1fff.ffff
  3573.     HEX    1fff.ffff.1fff.ffff
  3574.     HEX    1fff.ffff.7fff.ffff
  3575.     HEX    ffff.ffff.ffff.ffff
  3576.     HEX    ffff.ffff.ffff.ffff
  3577.     HEX    ffff.ffff.ffff.ffff
  3578.     HEX    ffff.ffff.ffff.ffff
  3579.     HEX    ffff.fffe.ffff.fffe
  3580.     HEX    ffff.fffe.ffff.fffe
  3581.     HEX    ffff.fffe.ffff.fffc
  3582.     HEX    ffff.fff8.ffff.fffc
  3583.     HEX    ffff.fffe.ffff.f3ff
  3584.     HEX    ffff.f3ee.7fff.f1c6
  3585.     ENDR
  3586. *
  3587.     RSRC    WIND,256
  3588.     DATA    /40,/2,/326,/498
  3589.     DATA    /8
  3590.     DATA    #1,#0
  3591.     DATA    #0,#0
  3592.     DATA    0
  3593.     STR    "yerk.com"
  3594.     ENDR
  3595. *
  3596.     RSRC    BNDL,128
  3597.     ASC    'YERK'
  3598.     DATA    /0
  3599.     DATA    /2-1
  3600.     ASC    'ICN#'
  3601.     DATA    /5-1
  3602.     DATA    /0,/128,/1,/129,/2,/130
  3603.     DATA    /3,/131,/4,/132
  3604.     ASC    'FREF'
  3605.     DATA    /5-1
  3606.     DATA    /0,/128,/1,/129,/2,/130
  3607.     DATA    /3,/131,/4,/132
  3608.     ENDR
  3609. *
  3610.     RSRC    SIZE,-1
  3611.     DATA    /$5880
  3612.     DATA    1022976
  3613.     DATA    393216
  3614.     ENDR
  3615. *
  3616.     RSRC    vers,1
  3617.     DATA    $03648000
  3618.     DATA    /0000
  3619.     STR    "3.6.4"
  3620.     STR    "3.6.4 Yerkes Observatory"
  3621.     ENDR
  3622. *
  3623.     END
  3624.